Dinamik hücre Kopyalama

[sercio_sercio]

Merhaba,

Benim excel'de dinamik hücre kopyalama ile ilgili bir sorum olacak.
Makro yazmaya yeni başladığım için sizden yardımınızı rica edeceğim.

Sorun şu;

Excel de satır tagleri birbirinin aynısı üç ayrı dikey hücre serisi var buradan aşağıya doğru ise satırları değişen sütün tagleri de değişen üç ayrı hücre serisi daha var bu iki serinin birinci grup için satırları yanyana ikinci seri içinde yine satırları yan yana gelecek şekilde kopyalanıp diğer bir sheet'e kopyalanması gerekiyor.

Burada asıl mesele bu satır sayısının ve gruplar içerisindeki seri sayısının değişiyor olması

sanırım biraz karışık oldu ama ekteki excel'de bir örnek bulabilirsiniz,

Yardımcı olabilirseniz sevinirim

 

[Korhan Ayhan]

Merhaba,

Forumumuza hoşgeldiniz.

İstediğiniz işlem "A" sütunundaki verilerin döngüye alınması ile rahatlıkla yapılabilir.

Aşağıdaki kod "A" sütunundaki parçalı verileri bloklar halinde gruplayarak diğer sayfaya aktarır.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Alan As Range, Say As Integer, Bul As Range
    Dim Satır As Long, Sütun As Byte
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("AnaSayfa")
    Set S2 = Sheets("Oluşturmakİstediğim")
    
    S2.Range("A:D").Clear
    S2.Columns("B:D").HorizontalAlignment = xlCenter
    
    For Each Alan In S1.Range("A:A").SpecialCells(xlCellTypeConstants, 23).Areas
        Say = Alan.Count
        If Say > 1 Then
            If S1.Cells(Alan.Row - 1, "B") = "A" Then
                Sütun = 2
            ElseIf S1.Cells(Alan.Row - 1, "B") = "B" Then
                Sütun = 3
            ElseIf S1.Cells(Alan.Row - 1, "B") = "C" Then
                Sütun = 4
            End If
            
            Set Bul = S2.Range("a:a").Find(Say, , , xlWhole)
                If Not Bul Is Nothing Then
                    
                    S2.Cells(Bul.Row + 1, Sütun).Resize(Say) = Alan.Offset(, 1).Resize(Alan.Rows.Count).Value
                
                Else
                
                    If S2.Range("A1") = "" Then
                        Satır = 1
                    Else
                        Satır = S2.Cells(Rows.Count, 1).End(3).Row + 3
                    End If
                    
                    S2.Cells(Satır, "A") = Say
                    S2.Cells(Satır, "B") = "A"
                    S2.Cells(Satır, "C") = "B"
                    S2.Cells(Satır, "D") = "C"
                    S2.Range("B" & Satır, "D" & Satır).Font.Bold = True
                    S2.Range("B" & Satır, "D" & Satır).Font.ColorIndex = 3
                
                    S2.Cells(Satır + 1, Sütun - 1).Resize(Say) = Alan.Value
                    S2.Cells(Satır + 1, Sütun).Resize(Say) = Alan.Offset(, 1).Resize(Alan.Rows.Count).Value
                
                End If
        End If
    Next
 
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[sercio_sercio]

Korhan bey elinize sağlık yazdığınız makro verdiğim örnek için çok iyi çalışıyor ancak ben gerçek tablolar üzerinde denediğimde hata veriyor düzgün çalıştırabilmem için hangi satırları değiştirmem gerekir acaba? Tabloları ekledim bakmanız mümkün olabilir mi? Birde zahmet olmazsa kod satırlarının açıklamasını yazabilirmisiniz?

Teşekkürler