根据条件从一个工作簿获取数据到另一个工作簿

Question

我在将数据从其他工作簿获取到主文件时遇到问题。因此，在主文件中有一个工作时间表，有五列（国家填充、植物填充、月份填充、周填充、工作时间为空）。我需要从其他工作簿中获取工作时间。其他工作簿存储在一个文件夹中。

我打开每个工作簿并查找合适的工作表，然后查找合适的周号。最后，只有当其他工作簿满足条件时，我才需要从它们复制数据（在主文件中，我寻找正确的行（植物+月份+周），然后我需要在其他工作簿中执行相同的操作。如果两个条件都是相同，那么工作时间应该复制到主文件 - 但仅限这一行。

我的代码仅适用于 week = 1。如果我将其更改为 2,3 或其他值，那么它不会复制任何内容。

Sub GetData()

    ' Deklaracja zmiennych
    Dim path As String
    Dim masterFile As String
    Dim monthNo As Integer
    Dim weekNo As Integer
    Dim plantList As Collection
    Dim item As Variant
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim cell As Range
    Dim wb2 As Workbook
    Dim ws2 As Worksheet
    Dim workingHours As Double
    Dim foundRow As Range
    Dim plantName As String

    ' Uzupelniam kolekcje
    Set plantList = New Collection

    ' Dodanie nazw zakladów do kolekcji
    plantList.Add "Warszawa"
    plantList.Add "Czestochowa"
    plantList.Add "Zabrze"
    plantList.Add "Wroclaw"
    plantList.Add "Rzeszow"
    plantList.Add "Liberec"
    plantList.Add "Brno"
    plantList.Add "Krnov"
    plantList.Add "Prague"
    plantList.Add "Izmir"
    plantList.Add "Izmir (2)"
    plantList.Add "Bursa"
    plantList.Add "Gebze"
    plantList.Add "Jinan"
    plantList.Add "Kunshan"
    plantList.Add "Taicang"
    plantList.Add "Wuxi"
    plantList.Add "Jiaxing"
    plantList.Add "Vlkanova"
    plantList.Add "Budapest"
    plantList.Add "Brasov"

    ' Przypisanie sciezki do folderu
    path = "..."
    masterFile = "..." ' Nazwa pliku master
    
    ' Numer miesiaca i tygodnia
    monthNo = 10
    weekNo = 2
    
    ' Otwórz plik glówny
    Set wb2 = Workbooks(masterFile)
    Set ws2 = wb2.Worksheets("Working hours") ' Zakladam, ze dane beda w arkuszu "Working hours"

    ' Przeszukaj pliki w folderze
    fileName = Dir(path & "*.xlsm")

    ' Petla przez wszystkie pliki w folderze
    Do While fileName <> ""
    
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Set wb = Workbooks.Open(path & fileName)
        Application.ScreenUpdating = True
        
        ' Petla przez wszystkie arkusze w pliku
        For Each ws In wb.Sheets
            ' Sprawdz, czy nazwa arkusza znajduje sie w kolekcji
            For Each item In plantList
                If ws.Name = item Then
                    plantName = ws.Name ' Zapisz nazwe zakladu (arkusza)
                    
                    ' Petla przez komórki w zakresie B33:B38
                    For Each cell In ws.Range("B33:B38")
                        ' Jesli wartosc komórki jest równa weekNo
                        If cell.Value = weekNo Then
                            ' Pobierz wartosc z kolumny H w tym samym wierszu
                            workingHours = cell.Offset(0, 6).Value + cell.Offset(0, 8).Value + cell.Offset(0, 10).Value + cell.Offset(0, 12).Value + cell.Offset(0, 14).Value + cell.Offset(0, 16).Value + cell.Offset(0, 18).Value
                            
                            ' Szukaj odpowiedniego miejsca w masterFile
                            Set foundRow = Nothing
                            Set foundRow = ws2.Range("B:B").Find(What:=plantName, LookIn:=xlValues, LookAt:=xlWhole)
                            
                            If Not foundRow Is Nothing Then
                                ' Sprawdz, czy miesiac i tydzien pasuja
                                If foundRow.Offset(0, 1).Value = monthNo And foundRow.Offset(0, 2).Value = weekNo Then
                                    ' Wstaw working hours do kolumny E w odpowiednim wierszu
                                    foundRow.Offset(0, 3).Value = workingHours
                                End If
                            End If
                        End If
                    Next cell
                    
                End If
            Next item
        Next ws
        
        ' Zapisz i zamknij plik
        wb.Save
        wb.Close False
        
        ' Przejdz do kolejnego pliku
        fileName = Dir
        
    Loop
    
    Application.DisplayAlerts = True
    ' Wyswietl komunikat o zakonczeniu
    MsgBox "Job done!"

End Sub

Answer 1

正如黑猫所说，你需要使用

FindNext

继续搜索 B 列

    Set foundRow = Nothing
    Set foundRow = ws2.Range("B:B").Find(What:=plantName, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not foundRow Is Nothing Then
        firstAddr = foundRow.Address
        
        Do
            ' Sprawdz, czy miesiac i tydzien pasuja
            If foundRow.Offset(0, 1).Value = monthNo And foundRow.Offset(0, 2).Value = weekNo Then
                ' Wstaw working hours do kolumny E w odpowiednim wierszu
                foundRow.Offset(0, 3).Value = workingHours
            End If
            Set foundRow = ws2.Range("B:B").FindNext(foundRow)
           
        Loop While foundRow.Address <> firstAddr
        
    End If