İsteğe Göre Veri Aktarma Makro ile

[Ahmet Sami]

Arkadaşlar sizden istediğim yardım. F8 'e barkod numarasını girince VERİ sayfasında bulunan barkodu 22 olan tüm ürünlerin buraya AKTAR butonuna tıklayarak aktarılması (R8 boş olursa), Ancak R8 'e 1 yazdığım zaman ise VERİ sayfasında R sütununda bulunan Barkod numarası 22 ye ait olan sadece 1 'lerin buraya aktarılması, Ancak R8'deki 1 rakamı VERİ sayfasına veri girdikçe artacaktır. yani 1,2,3,4,5.... örnekteki gibi
Yardımlarınız için şimdiden teşekkür ederim. Örnek dosya ektedir.

 

[veyselemre]

Sub test()
    If ActiveSheet.Name <> "ANASAYFA" Then Exit Sub
    Set sv = Sheets("VERİ")

    son = sv.Cells(Rows.Count, 2).End(3).Row

    With CreateObject("Scripting.Dictionary")

        For i = 3 To son

            key1 = sv.Cells(i, "B").Value & "|"
     
            If Not .exists(key1) Then
                .Item(key1) = i & ":" & i
            Else
                .Item(key1) = .Item(key1) & "," & i & ":" & i
            End If

            key1 = key1 & sv.Cells(i, "P").Value
            If Not .exists(key1) Then
                .Item(key1) = i & ":" & i
            Else
                .Item(key1) = .Item(key1) & "," & i & ":" & i
            End If

        Next
        Range("11:" & Rows.Count).Delete shift:=xlUp
        key = [f8].Value & "|" & [R8].Value
        Intersect(sv.Range(.Item(key)), sv.Range("B:P")).Copy [b11]

    End With

End Sub

 

[Ahmet Sami]

Veysel Bey öncelikle ilginizden dolayı teşekkür ederim.
Aktarma işlemini yapıyor, ancak yanlış bir rakam girdiğim zaman yani R8 hücresine F8 hücresindeki barkod numarasına uymayan bir rakam girdiğim zaman Run-time error 1004 diye bir pencere açılıyor, Pencerenin açılmasından ziyade yanlış rakam girdiniz gibi bir uyarı ile beni uyarması mümkün müdür.

 

[veyselemre]

Sub test()
    If ActiveSheet.Name <> "ANASAYFA" Then Exit Sub
    Set sv = Sheets("VERİ")

    son = sv.Cells(Rows.Count, 2).End(3).Row

    With CreateObject("Scripting.Dictionary")

        For i = 3 To son

            key1 = sv.Cells(i, "B").Value & "|"

            If Not .exists(key1) Then
                .Item(key1) = i & ":" & i
            Else
                .Item(key1) = .Item(key1) & "," & i & ":" & i
            End If

            key1 = key1 & sv.Cells(i, "P").Value
            If Not .exists(key1) Then
                .Item(key1) = i & ":" & i
            Else
                .Item(key1) = .Item(key1) & "," & i & ":" & i
            End If

        Next
        Range("11:" & Rows.Count).Delete shift:=xlUp
        key = [f8].Value & "|" & [R8].Value
        If .exists(key) Then
            Intersect(sv.Range(.Item(key)), sv.Range("B:P")).Copy [b11]
        Else
            MsgBox "Aradığınız barkod bulunamadı..."
        End If

    End With

End Sub