多工作簿中的某一个指定sheet内容汇总!

tanglf188

参与一下，练手

无语住了我

ykcbf1100 发表于 2024-6-18 15:52
总表数据处理为仅数值

🐂🐂

无语住了我

tanglf188 发表于 2024-6-18 17:01
参与一下，练手

无语住了我

ykcbf1100 发表于 2024-6-18 15:52
总表数据处理为仅数值

感谢

无语住了我

Sub ConsolidateWorksheets()
    ' 关闭屏幕更新和警告
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' 创建文件系统对象
    Set Fso = CreateObject("Scripting.FileSystemObject")

    ' 选择文件夹
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If fDialog.Show = -1 Then
        p = fDialog.SelectedItems(1) & "\"
    Else
        Exit Sub
    End If

    ' 设置汇总工作表
    Set sh = ThisWorkbook.Sheets("sheet1") ' 此修改汇总到的表格名称
    sh.UsedRange.Clear

    ' 遍历文件夹中的所有Excel文件
    For Each FileItem In Fso.GetFolder(p).Files
        If InStr(FileItem.Name, ThisWorkbook.Name) = 0 And FileItem.Name Like "*.xls*" Then
            fn = Fso.GetBaseName(FileItem)
            Set wbSource = Workbooks.Open(FileItem, 0)
            m = m + 1
            Set wsSource = wbSource.Sheets("原料价格预测")

            If m = 1 Then
                wsSource.Cells.Copy sh.[a1]
                DestRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
                sh.Rows(DestRow + 1).Delete
            Else
                DestRow = sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
                wsSource.Rows("5:" & wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row).Copy sh.Cells(DestRow, 1)
            End If

            ' 更新汇总信息
            Summary = Summary & fn & vbCrLf

            ' 关闭源工作簿
            wbSource.Close False
        End If
    Next FileItem

    ' 激活汇总工作表
    sh.Activate

    ' 打开屏幕更新
    Application.ScreenUpdating = True

    ' 显示汇总结果
    MsgBox "合并完毕!" & vbCrLf & "汇总的工作表数量: " & m & vbCrLf & "汇总的工作表名称：" & vbCrLf & Summary, vbInformation
End Sub

以上结果，是根据各位大佬代码，让chatGPT参考后的代码，实测可运用到我的测试数据中

无语住了我

Sub ConsolidateWorksheets()
    ' 关闭屏幕更新和警告
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' 创建文件系统对象
    Set Fso = CreateObject("Scripting.FileSystemObject")

    ' 选择文件夹
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If fDialog.Show = -1 Then
        p = fDialog.SelectedItems(1) & "\"
    Else
        Exit Sub
    End If

    ' 设置汇总工作表
    Set sh = ThisWorkbook.Sheets("sheet1") ' 此修改汇总到的表格名称
    sh.UsedRange.Clear

    ' 遍历文件夹中的所有Excel文件
    For Each FileItem In Fso.GetFolder(p).Files
        If InStr(FileItem.Name, ThisWorkbook.Name) = 0 And FileItem.Name Like "*.xls*" Then
            fn = Fso.GetBaseName(FileItem)
            Set wbSource = Workbooks.Open(FileItem, 0)
            m = m + 1
            Set wsSource = wbSource.Sheets("原料价格预测")

            If m = 1 Then
                wsSource.Cells.Copy sh.[a1]
                DestRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
                sh.Rows(DestRow + 1).Delete
            Else
                DestRow = sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
                wsSource.Rows("5:" & wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row).Copy sh.Cells(DestRow, 1)
            End If

            ' 更新汇总信息
            Summary = Summary & fn & vbCrLf

            ' 关闭源工作簿
            wbSource.Close False
        End If
    Next FileItem

    ' 激活汇总工作表
    sh.Activate

    ' 打开屏幕更新
    Application.ScreenUpdating = True

    ' 显示汇总结果
    MsgBox "合并完毕!" & vbCrLf & "汇总的工作表数量: " & m & vbCrLf & "汇总的工作表名称：" & vbCrLf & Summary, vbInformation
End Sub