Hey there!

It looks like you're enjoying Hesaptablosu - Akademik Excel Forumu but haven't created an account yet. Why not take a minute to register for your own free account now? As a member you get free access to all of our forums and posts plus the ability to post your own messages, communicate directly with other members and much more. Register now!

Already a member? Login at the top of this page to stop seeing this message.

Toplam 7 sonuçtan 1 ile 7 arasındakiler gösteriliyor.

Konu: SINIRLI AKTARMA

  1. #1
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.018

    SINIRLI AKTARMA

    Office Ver.: bilinmiyor
    Windows Ver.: Windows 10 Enterprise 64 bit
    + A B C D E F G H I J K L M N O P Q R S
    1 OCAK OCAK ŞUBAT MART NİSAN MAYIS HAZİRAN TEMMUZ AĞUSTOS EYLÜL EKİM KASIM ARALIK
    2 1200,00 1200,00
    3 1200,00 1200,00
    4 1200,00 1200,00
    5 1200,00 1200,00
    6 1200,00 1200,00
    7 1200,00 1200,00
    8 1200,00 1200,00
    9 1200,00 1200,00
    10 1200,00 1200,00
    11 1200,00 1200,00
    12 1200,00 1200,00
    13 1200,00 1200,00
    14 1200,00 1200,00
    15
    Sayfa İsmi: Sayfa3 ()
    XLtoHTML v1.2 / OfficeTürkiye - 2014©

    Merhaba Excel Dostları,
    Yukarıdaki tabloda 12 ay olduğu için makro ile 12 defa ile sınırlı olmak üzere aylık veriyi sütun başlığı ile birlikte aktarmak istiyorum.
    Örneklemek gerekirse;
    Örneğin C sütunundaki OCAK ayı verisi hazır. (Yalnız burada satır sayısı sabit değil değişken.)
    1-Butona tıkladığımda C sütununu başlığıyla birlikte H sütununa aktarsın
    2-T sütununda da H-S sütunlarını her aktardığımda toplam alsın. (Tabloda T sütunu görünmüyor)
    3-Hangi ayı aktardığımı mesaj ile bana bildirsin ( "Ocak ayı aktarıldı") Bu şekilde 12 ayı sırasıyla aktarabileyim.
    Destekleriniz için şimdiden teşekkürler.
    Bu vesile ile yeni yılınızı kutlar, gönlünüzden ecen her şeyin olmasını dilerim.

    not: ekli kod ile sadece Ocak ayını aktarabildim.

    Sub aktar_12()
    Dim s1 As Worksheet
    Set s1 = Worksheets("sayfa1")
    s1.Columns("c:c").Copy
    s1.Select
    a = s1.Range("A1").End(xlToRight).Column
    Cells(1, a + 5).Select
    ActiveSheet.Paste
    Range("c1").Select
    s1.Select
    Range("c1").Select
    Application.CutCopyMode = False
    End Sub
    Konu behcet tarafından (01.01.2018 Saat 14:22 ) değiştirilmiştir.

  2. #2
    Yeni Üye
    Üyelik tarihi
    Dec 2017
    Mesajlar
    28
    Lütfen deneyin.
    Kod:
    Sub AktarYeni()
    Dim Hedef As Range
    
    'C1 de yazan ay adının hangi sütunda olduğunu buluyoruz
    Set Hedef = Range("H1:S1").Find(Range("C1"), , xlValues, xlWhole, , xlNext)
    
    'belirtmemişsiniz ama, o sütundaki eski veriyi siliyorum. Satırlarda boşluk olmadığını varsayarak
    Range(Cells(2, Hedef.Column), Cells(Cells(2, Hedef.Column).End(xlDown).Row, Hedef.Column)).ClearContents
    
    'ilk satırdan son satıra kadar kopyalıyor ve T sütununa toplam değeri yazdırıyoruz
    For i = 2 To Range("C1").End(4).Row
        Cells(i, Hedef.Column) = Cells(i, 3)
        Cells(i, 20) = WorksheetFunction.Sum(Range(Cells(i, 8), Cells(i, 19)))
    Next i
    
    End Sub

  3. #3
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.018
    Merhaba Sayın NextLevel,
    Elinizi kolunuz gözünüz dert görmesin.
    Next i den sonra Minik bir ilave de ben yaptım tam istediğim gibi oldu.
    MsgBox (Range("C1").Value) & "-" & "AYINA AİT MATRAH AKTARILDI.", , "AÇIKLAMA"
    Sağlıcakla kalın.

  4. #4
    Yeni Üye
    Üyelik tarihi
    Dec 2017
    Mesajlar
    28
    Bir kaç ilave ve düzeltme ekledim ben de...

    Kod:
    Sub AktarYeni()
    Dim Hedef As Range
    '...............................................................................................................
    'C1 de yazan ay adının hangi sütunda olduğunu buluyoruz
    Set Hedef = Range("H1:S1").Find(Range("C1"), , xlValues, xlWhole, , xlNext)
    '...............................................................................................................
    'C1 deki ay adı doğru tanımlandığının kontrolü ve Uyarı mesajıyla prosedürün sonlandırılması
    On Error Resume Next  
    If Hedef.Column < 8 Or Hedef.Column > 19 Then
        MsgBox Range("H1") & " - Ay Geçerli Bir AY Adı Değil !!", vbCritical
        Range("H1").Select
        Exit Sub
    End If
    
    '.............................................................................................................
    'C1 deki AY adı doğru tanımlanmışsa aktarma ve toplama işlemlerinin başlangıcı
    '...............
    'belirtmemişsiniz ama, o sütundaki eski veriyi siliyorum. Satırlarda boşluk olmadığını varsayarak
    Range(Cells(2, Hedef.Column), Cells(Cells(2, Hedef.Column).End(xlDown).Row, Hedef.Column)).ClearContents
    
    'ilk satırdan son satıra kadar kopyalıyor ve T sütununa toplam değeri yazdırıyoruz
    For i = 2 To Range("C1").End(4).Row
        Cells(i, Hedef.Column) = Cells(i, 3)
        Cells(i, 20) = WorksheetFunction.Sum(Range(Cells(i, 8), Cells(i, 19)))
    Next i
    MsgBox Range("H1") & " - Ayına ait matrah aktarıldı.", vbInformation
    End Sub
    Konu NextLevel tarafından (02.01.2018 Saat 16:03 ) değiştirilmiştir.

  5. #5
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.018
    Merhaba Üstadım Sayın NextLevel,
    Yeni ilaveler için çok teşekkür ederim. Harika. Aslında bu haliyle işimi görüyor.
    Ancak insan kullandıkça yeni değişiklikler gerekiyor.
    Örneğin Şubat aktarılmışsa yani doluysa yeniden Şubat ayını aktarmaya kalktığımızda "Hata ! Şubat önceden aktarılmış" uyarısı yapabilir miyiz?
    Umarım sizi yormamış olurum.
    Sağlıcakla kalın.
    Konu behcet tarafından (03.01.2018 Saat 00:43 ) değiştirilmiştir.

  6. #6
    Yeni Üye
    Üyelik tarihi
    Dec 2017
    Mesajlar
    28
    Örneğin Şubat aktarılmışsa yani doluysa yeniden Şubat ayını aktarmaya kalktığımızda "Hata ! Şubat önceden aktarılmış" uyarısı yapabilir miyiz?
    Bundan anladığım H S arası sütunlarımız boş duruyor.. Benim önceki yazdığımda sütun doluysa diye siliyor ve yeniden yazıyordu.
    Aşağıdaki kodları kullanabilirsiniz.
    Kod:
    Sub AktarYeni()
    Dim Hedef As Range
    Set Hedef = Range("H1:S1").Find(Range("C1"), , xlValues, xlWhole, , xlNext)
    On Error Resume Next
    If Hedef.Column < 8 Or Hedef.Column > 19 Then
        MsgBox Range("H1") & " - Ay Geçerli Bir AY Adı Değil !!", vbCritical
        Range("H1").Select
        Exit Sub
    End If
    If WorksheetFunction.CountA(Columns(Hedef.Column)) > 1 Then
        Row1 = Range("C1") & " Ayı daha önce aktarılmış."
        Row2 = "Verileri yine de aktarmak istiyor musunuz?"
        Style = vbYesNo + vbQuestion + vbMsgBoxRight
        Title = "  ... AKTARMA UYARISI ..."
        response = MsgBox(Row1 & Chr(13) & Row2, Style, Title)
        If response = 6 Then
            GoTo DEVAM
        Else
            Range("C1").Select
            Exit Sub
        End If
    End If
    DEVAM:
    For i = 2 To Range("C1").End(4).Row
        Cells(i, Hedef.Column) = Cells(i, 3)
        Cells(i, 20) = WorksheetFunction.Sum(Range(Cells(i, 8), Cells(i, 19)))
    Next i
    MsgBox Range("C1") & " - Ayına ait matrah aktarıldı.", vbInformation, "   ... İŞLEM TAMAM"
    End Sub

  7. #7
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.018
    Merhaba Sayın NextLevel,
    Harika . Tam istediğim gibi Üstadım.
    Sayenizde farklı şeyler öğrendim. Ne kadar teşekkür etsem azdır.
    Her şey gönlünüzce olsun.

Konu Bilgisi

Users Browsing this Thread

Şu anda 1 üyemiz bu konuya göz atıyor. (0 kayıtlı üye ve 1 misafir.)

Yetkileriniz

  • Konu Acma Yetkiniz Yok
  • Cevap Yazma Yetkiniz Yok
  • Eklenti Yükleme Yetkiniz Yok
  • Mesajınızı Değiştirme Yetkiniz Yok
  •