Hücre değerine göre sayfalara veri aktarma

[kemal turan]

Merhaba,
Hücre değerine göre sayfalara veri aktarma hakkında yardımlarınızı rica ediyorum
Detay bilgiler ek dosyadadır.
Teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu dener misiniz?

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long, s As Long
Dim b As Byte
Dim msj As String

pst = Array("HASAN@KRLS.COM", "KEMAL@LDKJ.COM", "MEHMET@MFDG.COM")
syf = Array("HASANBEY", "KEMALBEY", "MEHMETBEY")
Set s1 = Sheets("VERILER")
s = s1.Cells(Rows.Count, "I").End(3).Row

For b = LBound(pst) To UBound(pst)
    Set s2 = Nothing
    On Error Resume Next
    Set s2 = Sheets(syf(b))
    On Error GoTo 0
    If Not s2 Is Nothing Then
        ReDim dz(1 To s, 1 To 9)
        x = 0
        For a = 2 To s
            If s1.Cells(a, "I") = pst(b) Then
                x = x + 1
                dz(x, 1) = Application.Max(s2.Range("A:A")) + x
                dz(x, 2) = s1.Cells(a, 2).Value
                'dz(x, 3) = s1.Cells(a, 3).Value
                dz(x, 4) = s1.Cells(a, 4).Value
                dz(x, 5) = s1.Cells(a, 5).Value
                'dz(x, 6) = s1.Cells(a, 6).Value
                dz(x, 7) = s1.Cells(a, 6).Value
                'dz(x, 8) = s1.Cells(a, 8).Value
                dz(x, 9) = s1.Cells(a, 7).Value
            End If
        Next
        s2.Cells(Rows.Count, "A").End(3)(2, 1).Resize(UBound(dz), UBound(dz, 2)).Value = dz
    Else
        msj = msj & pst(b) & " için sayfa atanmamış." & vbLf
    End If
Next
MsgBox IIf(msj = "", "İşlem başarılı.", "Hata oluştu:" & vbLf & msj)
End Sub

 

[kemal turan]

Ömer Hocam,
Çok teşekkür ederim.
Sağolun, Selametle kalın