Kriterlere göre veri aktarma

[mbattal]

Arkadaşlar Merhaba,
Forumdan bularak kendi dosyama uyarladığım kodlar sayesinde SORGU dosyasına aynı klasördeki diğer dosyalardan veri çekebiliyorum.
Benim istediğim SORGU dosyasına sonradan ilave ettiğim İŞ SORGULA ve OP SORGULA isimli Optionbutton lara göre veri alabilmek. Mevcut kodlarla İŞ SORGULA ya göre veri alınmaktadır.
Kodlara yapılacak ilave ve/veya düzeltmeler için yardımınıza ihtiyacım var.
Saygılarımla

 

[excel03]

merhaba;

Sub DOSYALARDAN_VERİ_AL()
'iş emri numarası yerine OP adını yazarak çalıştırınız.
    Range("C8:N100").Select
    Selection.ClearContents
    Range("G6").Select
    Dim FSO As Object, DOSYA As Object, DOSYA_YOLU As Object
    Dim DOSYALAR As Object, SATIR As Long, SÜTUN As Byte
    Dim X As Long, SON_SATIR As Long, TARİH As Date, MALZEME_ADI As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DOSYA_YOLU = FSO.GetFolder(ThisWorkbook.Path)
    Set DOSYALAR = DOSYA_YOLU.Files
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Sheets("DATA")
        .Range("C8:K65536").Clear
        .Range("C8:C65536").NumberFormat = "m/d/yyyy"
        .Range("j8:j65536").NumberFormat = "hh:mm;@"
        .Range("k8:k65536").NumberFormat = "hh:mm;@"
        .Range("L8:L65536").NumberFormat = "hh:mm;@"
        .Range("C7:L65536").HorizontalAlignment = xlCenter
    
        If .Range("A1") = "" Then
            MsgBox "Lütfen ilk tarihi giriniz !", vbCritical
            .Range("A1").Select
            Application.ScreenUpdating = True
            Exit Sub
        End If
    
        If .Range("A2") = "" Then
            MsgBox "Lütfen son tarihi giriniz !", vbCritical
            .Range("A2").Select
            Application.ScreenUpdating = True
            Exit Sub
        End If
    
   
    
    
    
        If .Range("G6") = "" Then
            
            If [a4] = 2 Then
            MsgBox "Lütfen OP ADINI giriniz !", vbCritical
            .Range("G6").Select
            Application.ScreenUpdating = True
            Exit Sub
            End If
            
            MsgBox "Lütfen iş emri numarasını giriniz !", vbCritical
            .Range("G6").Select
            Application.ScreenUpdating = True
            Exit Sub
        End If
    
        SATIR = 7
   If [a4] = 2 Then
        For Each DOSYA In DOSYALAR
            If DOSYA.Name <> "SORGU.xls" Then
                SON_SATIR = ExecuteExcel4Macro("COUNTA('" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!C1)") + 5
                For X = 7 To SON_SATIR
                    TARİH = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C1")
                    MALZEME_ADI = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C2")
                    If TARİH >= .Range("A1") And TARİH <= .Range("A2") And MALZEME_ADI = .Range("G6") Then
                        SATIR = SATIR + 1
                        For SÜTUN = 3 To 14
                            Cells(SATIR, SÜTUN) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C" & SÜTUN - 2)
                        
                        Next
                    End If
                Next
            End If
        Next
     End If
     
     For Each DOSYA In DOSYALAR
            If DOSYA.Name <> "SORGU.xls" Then
                SON_SATIR = ExecuteExcel4Macro("COUNTA('" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!C1)") + 5
                For X = 7 To SON_SATIR
                    TARİH = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C1")
                    MALZEME_ADI = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C3")
                    If TARİH >= .Range("A1") And TARİH <= .Range("A2") And MALZEME_ADI = .Range("G6") Then
                        SATIR = SATIR + 1
                        For SÜTUN = 3 To 14
                            Cells(SATIR, SÜTUN) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & DOSYA.Name & "]Sayfa1'!R" & X & "C" & SÜTUN - 2)
                        
                        Next
                    End If
                Next
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
    
    Set FSO = Nothing
    Set DOSYA_YOLU = Nothing
    Set DOSYALAR = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
       
End Sub

 

[mbattal]

Sayın excel03,
Ustam eline beynine sağlık. Çok teşekkür ederim.