Soru aktar

[sirkülasyon]

Sub AKTAR()
    Dim S1, S2 As Object
    Dim SAY, X, SATIR As Long
    Set S1 = Sheets("Malzeme Giriş")
    Set S2 = Sheets("koş")
    S2.[B:H].ClearContents
    If S1.[B2] = "" Then
    MsgBox "AKTARIM İŞLEMİ HATALI LÜTFEN MALZEME SEÇİNİZ !", vbCritical, "DİKKAT !"
    S2.[B2].Select
    Exit Sub
    End If
    SAY = WorksheetFunction.CountIf(S1.[B:F], S1.[B2])
    If SAY = 0 Then
    MsgBox "AKTARMAK İSTEDİĞİNİZ MAMUL KAYITLARDA BULUNAMAMIŞTIR !", vbExclamation, "UYARI !"
    Exit Sub
    End If
    S1.[B22:H22].Copy S2.[B2]
    SATIR = 22
    For X = 2 To S1.[B65536].End(3).Row
    If S1.Cells(X, 2) = S1.[B2] Then
    S2.Range("B" & SATIR & ":F" & SATIR) = S1.Range("B" & X & ":F" & X).Value
    SATIR = SATIR + 1
    End If
    Next
    S2.Cells.EntireColumn.AutoFit
    S2.[B:H].HorizontalAlignment = xlCenter
'    S2.[B:B].Style = "Currency"
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "AKTARIM İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
End Sub

Sadece B2 satırını aktarıyor. B2'den itibaren dolu satır ne kadar var ise tamamını aktarmasını nasıl düzenleyebiliriz?

 

[Muzaffer Ali]

Merhaba.

Örnek dosya eklemediğiniz ve detay vermediğiniz için test etmem mümkün değil ama sanırım aşağıdaki kodlar işinizi görecektir.
Deneyin.

Sub AKTAR()
    Dim S1, S2 As Object
    Dim SAY, X, SATIR As Long
    Dim Bak As Range
    Set S1 = Sheets("Malzeme Giriş")
    Set S2 = Sheets("koş")
    S2.[B:H].ClearContents
    
    For Each Bak In S1.Range("B2:B" & S1.Cells(Rows.Count, "B").End(xlUp).Row)
    
        If Bak = "" Then
            MsgBox "AKTARIM İŞLEMİ HATALI LÜTFEN MALZEME SEÇİNİZ !" & " B2 ile son dolu hücre arasında boş hücre var.", vbCritical, "DİKKAT !"
            S2.[B2].Select
            Exit Sub
        End If
        SAY = WorksheetFunction.CountIf(S1.[B:F], Bak)
        If SAY = 0 Then
            MsgBox "AKTARMAK İSTEDİĞİNİZ MAMUL KAYITLARDA BULUNAMAMIŞTIR !" & " B2 ile son dolu hücre arasındaki mamullerden biri bulunamamıştır.", vbExclamation, "UYARI !"
            Exit Sub
        End If
        S1.[B22:H22].Copy S2.[B2]
        SATIR = 22
        For X = 2 To S1.[B65536].End(3).Row
            If S1.Cells(X, 2) = Bak Then
                S2.Range("B" & SATIR & ":F" & SATIR) = S1.Range("B" & X & ":F" & X).Value
                SATIR = SATIR + 1
            End If
        Next
        S2.Cells.EntireColumn.AutoFit
        S2.[B:H].HorizontalAlignment = xlCenter
    Next
'    S2.[B:B].Style = "Currency"
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "AKTARIM İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
End Sub