按条件跨工作簿导入工时数据的VBA代码故障排查

主工作簿「Working Hours」工作表包含五列：国家（已填充）、工厂（已填充）、月份（已填充）、周数（已填充）、工时（空白）。需从指定文件夹的其他工作簿提取工时数据，仅当工厂+月份+周数三者完全匹配时，将对应工时写入主表。但当前VBA代码仅在weekNo=1时正常运行，改为2、3等其他周数时无法复制任何数据。

原VBA代码 #

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

问题根源与修复方案 #

1. 工厂查找逻辑缺陷 #

原代码使用Range.Find仅返回第一个匹配工厂的行，但主表中同一工厂对应多个月份/周数的行，导致非第一行的周数（如week=2）无法被匹配到。

2. 周数类型不匹配（潜在问题） #

若源文件中B33:B38的周数是文本格式，而weekNo是整数类型，直接cell.Value = weekNo会因类型不匹配导致判断失败。

修复后的完整代码 #

Sub GetData()

    ' 声明变量
    Dim path As String
    Dim masterFile As String
    Dim monthNo As Integer
    Dim weekNo As Integer
    Dim plantDict As Object ' 改用字典提升查找效率
    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
    Dim firstAddress As String ' 记录第一个匹配行地址，避免死循环

    ' 初始化工厂字典
    Set plantDict = CreateObject("Scripting.Dictionary")
    plantDict.Add "Warszawa", 1
    plantDict.Add "Czestochowa", 1
    plantDict.Add "Zabrze", 1
    plantDict.Add "Wroclaw", 1
    plantDict.Add "Rzeszow", 1
    plantDict.Add "Liberec", 1
    plantDict.Add "Brno", 1
    plantDict.Add "Krnov", 1
    plantDict.Add "Prague", 1
    plantDict.Add "Izmir", 1
    plantDict.Add "Izmir (2)", 1
    plantDict.Add "Bursa", 1
    plantDict.Add "Gebze", 1
    plantDict.Add "Jinan", 1
    plantDict.Add "Kunshan", 1
    plantDict.Add "Taicang", 1
    plantDict.Add "Wuxi", 1
    plantDict.Add "Jiaxing", 1
    plantDict.Add "Vlkanova", 1
    plantDict.Add "Budapest", 1
    plantDict.Add "Brasov", 1

    ' 文件夹路径与主文件名
    path = "..."
    masterFile = "..."
    
    ' 目标月份与周数
    monthNo = 10
    weekNo = 2
    
    ' 打开主工作簿
    Set wb2 = Workbooks(masterFile)
    Set ws2 = wb2.Worksheets("Working hours")

    ' 遍历文件夹内所有xlsm文件
    fileName = Dir(path & "*.xlsm")
    Do While fileName <> ""
    
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Set wb = Workbooks.Open(path & fileName)
        
        ' 遍历当前工作簿的所有工作表
        For Each ws In wb.Sheets
            ' 检查工作表是否在工厂列表中（字典查找比集合循环高效）
            If plantDict.Exists(ws.Name) Then
                plantName = ws.Name
                
                ' 遍历源表的周数范围
                For Each cell In ws.Range("B33:B38")
                    ' 强制转换类型，避免文本/数字不匹配
                    If CInt(cell.Value) = weekNo Then
                        ' 计算总工时
                        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
                                      
                        ' 查找主表中所有匹配当前工厂的行
                        Set foundRow = ws2.Range("B:B").Find(What:=plantName, LookIn:=xlValues, LookAt:=xlWhole)
                        If Not foundRow Is Nothing Then
                            firstAddress = foundRow.Address
                            Do
                                ' 检查月份与周数是否匹配
                                If foundRow.Offset(0, 1).Value = monthNo And foundRow.Offset(0, 2).Value = weekNo Then
                                    foundRow.Offset(0, 3).Value = workingHours
                                End If
                                ' 查找下一个匹配行
                                Set foundRow = ws2.Range("B:B").FindNext(foundRow)
                            Loop While Not foundRow Is Nothing And foundRow.Address <> firstAddress
                        End If
                    End If
                Next cell
            End If
        Next ws
        
        ' 关闭当前工作簿
        wb.Close False
        fileName = Dir
        
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Job done!"

End Sub

关键修改点说明 #

• 改用字典存储工厂列表：替代原集合，工作表存在性判断从O(n)变为O(1)，提升效率。
• 循环查找所有匹配工厂的行：使用FindNext遍历主表中所有同一工厂的行，确保每个匹配的月份/周数组合都被处理。
• 强制类型转换：用CInt(cell.Value)统一周数类型，避免文本与数字的匹配失败。
• 优化屏幕更新逻辑：将Application.ScreenUpdating = True移到循环结束后，减少界面闪烁，提升运行速度。

内容的提问来源于stack exchange，提问作者Hubert S