şarta bağlı veri birleştirme

[umit1907]

Merhabalar,
30 günlük bir veri tablomuz var bunların "b" hücresinde "A" yazanları döküm sayfasına toplu aktarmak istiyoruz bunu makro ile nasıl yapabiliriz.

 

[Korhan Ayhan]

Deneyiniz.

Sub Aktar()
    Dim S1 As Worksheet, Sayfa As Worksheet, X As Byte, Satir As Long, Y As Byte
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("DÖKÜM")
    
    S1.Range("A3:AC" & Rows.Count).ClearContents
    Satir = 3
    
    For X = 1 To 31
        On Error Resume Next
        Set Sayfa = Sheets(CStr(X))
        On Error GoTo 0
        If Not Sayfa Is Nothing Then
            For Y = 7 To 33
                If Sayfa.Cells(Y, 2) = "A" Then
                    S1.Range("A" & Satir & ":AC" & Satir).Value = Sayfa.Range("C" & Y & ":AE" & Y).Value
                    Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                End If
            Next
        End If
    Next
    
    Application.CutCopyMode = False
    S1.Cells.Columns.AutoFit
    
    Set Sayfa = Nothing
    Set S1 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[umit1907]

Teşekkürler Korhan Abi eline sağlık.