汇总某文件夹中所有工作薄的第一个工作表的5到最后一行

Sub 汇总工作簿()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long
    Dim targetLastRow As Long
    Dim startRow As Long
    Dim fd As fileDialog
    Dim row As Long
    Dim pic As Picture

    On Error GoTo ErrorHandler ' 启用错误处理

    ' 设置目标工作表
    Set targetWs = ThisWorkbook.Sheets(1) ' 假设当前工作簿的第一个工作表为目标工作表

    ' 获取目标工作表的最后一行
    targetLastRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row

    ' 创建文件夹选择对话框
    Set fd = Application.fileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "选择文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub ' 用户取消选择
        folderPath = .SelectedItems(1) & "\"
    End With

    ' 遍历文件夹中的所有文件
    fileName = Dir(folderPath & "*.xls*")
    Do While fileName <> ""
        ' 打开工作簿
        On Error Resume Next ' 暂时忽略错误
        Set wb = Workbooks.Open(folderPath & fileName)
        If Err.Number <> 0 Then
            MsgBox "无法打开文件: " & folderPath & fileName & vbCrLf & "错误: " & Err.Description, vbExclamation
            Err.Clear
            GoTo NextFile
        End If
        On Error GoTo ErrorHandler ' 恢复错误处理

        ' 设置第一个工作表
        Set ws = wb.Sheets(1)

        ' 获取第一个工作表的最后一行
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

        ' 如果最后一行小于5，则跳过
        If lastRow >= 5 Then
            ' 设置起始行
            startRow = 5

            ' 遍历每一行，检查是否只有第一列的数据
            For row = startRow To lastRow
                ' 检查每一行是否只有第一列的数据
                If Application.WorksheetFunction.CountA(ws.Rows(row)) > 1 Then
                    ' 复制数据到目标工作表，不复制图片
                    ws.Rows(row).Copy Destination:=targetWs.Cells(targetLastRow + 1, 1)
                    ' 更新目标工作表的最后一行
                    targetLastRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row
                End If
            Next row
        End If

        ' 关闭工作簿
        wb.Close SaveChanges:=False

NextFile:
        ' 获取下一个文件
        fileName = Dir
    Loop

    ' 删除目标工作表中的所有图片
    For Each pic In targetWs.Pictures
        pic.Delete
    Next pic

    MsgBox "汇总完成！"
    Exit Sub

ErrorHandler:
    MsgBox "发生错误: " & Err.Description, vbExclamation
End Sub