Yardım Kapalı Excel Kitaplarından Ado ile Şartlı Veri Güncelleme Hk.

Sub ImportDataFromMultipleWorkbooks()
    Dim vaFiles As Variant, wbkToCopy As Workbook, ws As Worksheet, wsa As Worksheet, osma As Range
    ThisWorkbook.Activate
    Set ws = Sheet2
    un = "Dear " & Environ("UserName")
    ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks", vbInformation + vbYesNo, un)
    If ms1 = vbYes Then
        'Intersect(ws.Range("4:175"), ws.Range("C:E,F:F,H:H,J:J,L:L,O:O,R:R")).ClearContents
        ChDir (ThisWorkbook.Path)
        vaFiles = Application.GetOpenFilename( _
                  FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
                  Title:="Select Files to Proceed", MultiSelect:=True)
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = False
        End With
        say = ws.Cells(175, 3).End(3).Row + 1
        If say < 4 Then say = 4
        If IsArray(vaFiles) Then
            For i = LBound(vaFiles) To UBound(vaFiles)
                If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                    ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                    GoTo skipfile:
                End If
                Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
                Set wsa = ActiveWorkbook.ActiveSheet
                
                Set osma = ThisWorkbook.Worksheets(1).Columns(3).Find(wsa.Range("B2").Value, , , 1)
                If Not osma Is Nothing Then
                    ws.Cells(osma.Row, "C") = wsa.Range("B2")
                    ws.Cells(osma.Row, "D") = wsa.Range("B1")
                    ws.Cells(osma.Row, "E") = wsa.Range("B5")
                    ws.Cells(osma.Row, "F") = wsa.Range("P4")
                    ws.Cells(osma.Row, "H") = wsa.Range("Q4")
                    ws.Cells(osma.Row, "J") = wsa.Range("S4")
                    ws.Cells(osma.Row, "L") = wsa.Range("T4")
                    ws.Cells(osma.Row, "O") = wsa.Range("B3")
                    ws.Cells(osma.Row, "R") = wsa.Range("B4")
                    wbkToCopy.Close savechanges:=False
                        Else
                    ws.Cells(say, "C") = wsa.Range("B2")
                    ws.Cells(say, "D") = wsa.Range("B1")
                    ws.Cells(say, "E") = wsa.Range("B5")
                    ws.Cells(say, "F") = wsa.Range("P4")
                    ws.Cells(say, "H") = wsa.Range("Q4")
                    ws.Cells(say, "J") = wsa.Range("S4")
                    ws.Cells(say, "L") = wsa.Range("T4")
                    ws.Cells(say, "O") = wsa.Range("B3")
                    ws.Cells(say, "R") = wsa.Range("B4")
                    wbkToCopy.Close savechanges:=False
                    say = say + 1
                End If
skipfile:
            Next i
            ms5 = MsgBox("Data Import Finished", vbInformation, un)
        Else
            ms3 = MsgBox("No Files Selected", vbExclamation, un)
        End If
    Else
        ms2 = MsgBox("Cancelled", vbInformation, un)
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub