VBA从多Excel工作簿提取指定数据 代码运行中断问题求助

问题说明 #

需要使用通配符匹配指定后缀名的文件，从多个工作簿中提取黄色标签工作表内、绿色高亮列名下方红色框区域的数据，原有代码仅完成表头创建后就停止运行。

完整实现代码 #

Private Sub CommandButton3_Click()
    ' 声明变量
    Dim JCN As String, Path As String, ReportName As String, UserName As String
    Dim sourceWB As Workbook, targetWS As Worksheet, sourceWS As Worksheet
    Dim nextRow As Long, lastRow As Long, headerRow As Long, colCnt As Long
    Dim FILE_SUFFIX As String, fileName As String
    Const YELLOW_TAB_COLOR = 6 ' 黄色工作表标签ColorIndex，可按需调整
    Const GREEN_HEADER_COLOR = xlThemeColorAccent3 ' 绿色高亮表头主题色，可按需调整
    
    UserForm1.Hide
    JCN = TextBox3.Value
    ReportName = JCN & " PANEL NESTING REPORT"
    UserName = Environ$("Username")
    Path = "C:\Users\" & UserName & "\Desktop\"
    FILE_SUFFIX = "*.xlsx" ' 替换为你需要匹配的指定后缀通配符
    
    ' 创建新报表工作簿
    Workbooks.Add
    Set targetWS = ActiveWorkbook.Sheets(1)
    targetWS.Name = "NESTING REPORT"
    
    ' 写入并格式化表头
    With targetWS
        .Range("B1").Value = "WBS Code"
        .Range("C1").Value = "Airline Code"
        .Range("D1").Value = "JCN"
        .Range("E1").Value = "'3000LVL"
        .Range("F1").Value = "MBOM"
        .Range("G1").Value = "Make Part"
        .Range("H1").Value = "LAV"
        .Range("I1").Value = "LC Number"
        .Range("J1").Value = "Rev"
        .Range("K1").Value = "Size"
        .Range("L1").Value = "Part Number"
        .Range("M1").Value = "Rev"
        .Range("N1").Value = "Qty"
        .Range("O1").Value = "Classification"
        .Range("P1").Value = "Type"
        .Range("Q1").Value = "Thickness"
        .Range("R1").Value = "Rawmat"
        .Range("S1").Value = "Remarks"
        .Range("T1").Value = "'.400 Code"
        .Range("U1").Value = "W.O."
        
        ' 表头格式设置
        With .Range("B1:U1")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            With .Interior
                .Pattern = xlSolid
                .ThemeColor = xlThemeColorLight2
                .TintAndShade = -0.499984740745262
            End With
            .Font.ThemeColor = xlThemeColorDark1
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlThin
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
        End With
        .Columns("B:U").EntireColumn.AutoFit
        .Parent.Windows(1).DisplayGridlines = False
    End With
    nextRow = 2 ' 第一条数据写入的起始行
    
    ' ----------------------
    ' 新增：遍历提取数据逻辑
    ' ----------------------
    fileName = Dir(Path & FILE_SUFFIX)
    Do While fileName <> ""
        ' 跳过当前生成的报表文件
        If fileName <> ReportName & ".xlsx" Then
            Set sourceWB = Workbooks.Open(Path & fileName, ReadOnly:=True)
            ' 遍历当前工作簿所有工作表，找黄色标签的工作表
            For Each sourceWS In sourceWB.Sheets
                If sourceWS.Tab.ColorIndex = YELLOW_TAB_COLOR Then
                    ' 找绿色高亮的表头行
                    For headerRow = 1 To 50 ' 默认从第一行到第50行找表头，可按需调整范围
                        If sourceWS.Cells(headerRow, 2).Interior.ThemeColor = GREEN_HEADER_COLOR Then Exit For
                    Next headerRow
                    If headerRow > 50 Then GoTo nextSheet ' 没找到绿色表头就跳过当前工作表
                    
                    ' 确定红色框区域的最后一行
                    lastRow = sourceWS.Cells(sourceWS.Rows.Count, 2).End(xlUp).Row
                    If lastRow <= headerRow Then GoTo nextSheet ' 表头下方没有数据就跳过
                    
                    ' 复制红色框区域数据到新报表
                    colCnt = targetWS.Range("B1:U1").Columns.Count
                    sourceWS.Range(sourceWS.Cells(headerRow + 1, 2), sourceWS.Cells(lastRow, colCnt + 1)).Copy _
                    targetWS.Cells(nextRow, 2)
                    
                    ' 更新下一条数据的写入行号
                    nextRow = nextRow + (lastRow - headerRow)
                End If
nextSheet:
            Next sourceWS
            sourceWB.Close SaveChanges:=False
        End If
        fileName = Dir
    Loop
    
    ' 保存关闭报表
    targetWS.Parent.SaveAs Filename:=Path & ReportName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    targetWS.Parent.Close
    
    MsgBox "数据提取完成，报表已保存到桌面"
End Sub

使用说明 #

• 代码中FILE_SUFFIX = "*.xlsx"可替换为你需要匹配的后缀通配符，比如要匹配所有xls格式文件改为"*.xls*"即可
• 若实际文件的黄色标签、绿色表头的颜色值和代码中不一致，可选中对应元素后在VBA立即窗口执行? ActiveSheet.Tab.ColorIndex或? Selection.Interior.ThemeColor获取真实值后替换常量即可
• 默认遍历桌面文件夹下的所有匹配文件，若目标文件存放在其他路径，修改Path变量即可

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