Veri süzme konusunda yardım

[EXTRANET]

Merhaba Arkadaşlar.

Ekte rapor ve veri dosyaları buunmaktadır. Veri dosyasında 10 sayfa ve 40.000 adet veri kayıtlıdır.

Saygıdeğer arkadaşlar yardımınızı istediğim konu; Ana sayfa dosyasına veri dosyasındaki bilgilerin stok kodu ve stok adıne göre veri aktarabilirmiyiz. Teşekürler

Sayglarımla.

 

[Korhan Ayhan]

Merhaba,

İki dosyanızıda aynı klasör altına alın ve aşağıdaki kodu "Rapor" isimli dosyanızda çalıştırın.

Örnek dosyalar ektedir.

Option Explicit
 
Sub AKTAR()
    Dim K1 As Workbook
    Dim K2 As Workbook
    Dim S1 As Worksheet
    Dim Dosya As String
    Dim Stok_Kodu As String
    Dim Depo_Kodu As String
    Dim Sayfa As Worksheet
    Dim Satir As Long
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    S1.Range("A8:J" & S1.Rows.Count).ClearContents
    
    Stok_Kodu = S1.Range("B1")
    Depo_Kodu = S1.Range("B2")
    
    If Stok_Kodu = "" Then
        MsgBox "Stok kodu boş!" & Chr(10) & "Lütfen kontrol ediniz.", vbCritical
        S1.Range("B1").Select
        Exit Sub
    End If
    
    If Depo_Kodu = "" Then
        MsgBox "Depo kodu boş!" & Chr(10) & "Lütfen kontrol ediniz.", vbCritical
        S1.Range("B2").Select
        Exit Sub
    End If
    
    Dosya = K1.Path & "\veri.xls"
    Set K2 = Workbooks.Open(Dosya, False)
    
    Satir = 8
    
    For Each Sayfa In K2.Worksheets
        Sayfa.Range("A1").AutoFilter 1, Stok_Kodu
        Sayfa.Range("A1").AutoFilter 2, Depo_Kodu
        Sayfa.Range("A1").CurrentRegion.Copy
        S1.Cells(Satir, 1).PasteSpecial
        S1.Rows(Satir).Delete
        Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
        Sayfa.Range("A1").AutoFilter
    Next
    
    K2.Close False
    S1.Range("A1").Select
    S1.Cells.Font.Name = "Calibri"
    S1.Range("A:J").EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    If S1.Range("A8") = "" Then
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    Else
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "Toplam Listelenen Kayıt Sayısı : " & S1.Cells(S1.Rows.Count, 1).End(3).Row - 7, vbInformation
    End If
 
    Set K1 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
End Sub

 

[EXTRANET]

Korhan Bey,
çok teşekür ederim.Allah razı olsun.