[已解决]求多个工作簿数据合并到一个工作簿里面

wzd28

数据的工作簿暂上传7个（有可能有十几个工作簿），汇总表一个，如何用VBA把有数据的工作簿合并到汇总表里，数据会根据申请部门会有增加或减少，各数据表“用途”里面的文字也要汇总到汇总表里，汇总表里面已做数据汇总样式，请按样式汇总，谢谢！

    新建文件夹.rar (79.36 KB, 下载次数: 13)

2022-1-13 22:11 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-1-18 19:02

wzd28 发表于 2022-1-17 21:28
老师，谢谢你帮忙，拆分后出现几个问题，能否设置一下，谢谢！
1、拆分表格文件名显示“╊だ”，能否改 ...

已更新請再測試看看，謝謝

Sub Sorting()
Dim Arr, xD, s%, n%, i&, i2&
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Tm = Timer
Arr = Sheets(1).[a1].CurrentRegion
Set xD = CreateObject("scripting.dictionary")
For i = 4 To UBound(Arr)
    If xD.exists(Arr(i, 2)) Then
        Set xD(Arr(i, 2)) = Union(xD(Arr(i, 2)), Rows(i))
    Else
        Set xD(Arr(i, 2)) = Union(Rows(2), Rows(3), Rows(i))
    End If
Next
Workbooks.Add
For i = Sheets.Count To 2 Step -1: Sheets(i).Delete: Next
For i = 0 To xD.Count - 1
    With Sheets(i + 1)
        xD.items()(i).Copy Sheets(i + 1).[a1]
        .Name = xD.keys()(i)
    End With
    If Sheets.Count < xD.Count Then ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
Next
For i = 1 To Sheets.Count
    With Sheets(i)
        .Rows("1:1").Insert
        .[a1] = "月度采购计划汇总表"
        .Range(.Cells(1, 1), .Cells(1, 22)).MergeCells = True
        .Range(.Cells(1, 1), .Cells(1, 22)).HorizontalAlignment = xlCenter
        Arr = .[a1].CurrentRegion
        For i2 = 4 To UBound(Arr): n = n + 1: Arr(i2, 1) = n: s = s + Arr(i2, 20): Next
        .Range("a1").Resize(UBound(Arr), 1) = Arr: .Cells(n + 4, 19) = "合计"
        .Cells(n + 4, 20) = s: .Cells(n + 4, 20).NumberFormatLocal = "0.00_ "
        .Range(.Cells(n + 4, 1), .Cells(n + 4, 22)).Borders.LineStyle = xlContinuous
        n = 0: s = 0
    End With
Next
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "采购明细拆分"
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox Timer - Tm
End Sub

跳转到最佳答案楼层

sam-wang

請問數量為何不一樣? 請確認，謝謝

wzd28

sam-wang 发表于 2022-1-14 08:40
請問數量為何不一樣? 請確認，謝謝

你好，应该是我手动输入时输错了数值。

sam-wang

wzd28 发表于 2022-1-14 08:52
你好，应该是我手动输入时输错了数值。

請測試看看，謝謝
Sub test()
Dim Arr, xD, Brr(1 To 200, 1 To 15), a$, a1$, fs, f, fc, f1
Dim n%, m%, T$, DP%, i&, j%
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set xD = CreateObject("Scripting.Dictionary")
Set fs = CreateObject("Scripting.FileSystemObject")
a = ThisWorkbook.Path: Tm = Timer
Set f = fs.GetFolder(a): Set fc = f.Files
For Each f1 In fc
    a1 = f1.Name: If InStr(a1, "~") Then GoTo 97
    If InStr(a1, ThisWorkbook.Name) Then GoTo 97
    With Workbooks.Open(f1.Path)
        Arr = Sheets(1).[a2].CurrentRegion
        .Close
    End With
    If InStr(a1, "后勤") Then
    DP = 8
    ElseIf InStr(a1, "膳食") Then DP = 9
    ElseIf InStr(a1, "医养服务部") Then DP = 10
    ElseIf InStr(a1, "财务部") Then DP = 11
    ElseIf InStr(a1, "仓库") Then DP = 12
    ElseIf InStr(a1, "品质客服部") Then DP = 13
    ElseIf InStr(a1, "综合办公室") Then DP = 14
    End If
    For i = 3 To UBound(Arr)
        T = Arr(i, 4): If T = "" Then GoTo 96
        If xD.Exists(T) Then
            m = xD(T): Brr(m, DP) = Arr(i, 10): Brr(m, 15) = Brr(m, 15) + Arr(i, 10)
            If Arr(i, 12) <> "" Then
                If Brr(m, 7) = "" Then
                    Brr(m, 7) = Arr(1, 7) & ":" & Arr(i, 12)
                Else
                    Brr(m, 7) = Brr(m, 7) & " ; " & Arr(1, 7) & ":" & Arr(i, 12)
                End If
            End If
        Else
            n = n + 1: xD(T) = n: Brr(n, 1) = n
            For j = 2 To 6: Brr(n, j) = Arr(i, j): Next
            If Arr(i, 12) <> "" Then Brr(n, 7) = Arr(1, 7) & ":" & Arr(i, 12)
            Brr(n, DP) = Arr(i, 10): Brr(n, 15) = Arr(i, 10)
        End If
96: Next
97: Next
With Sheets(1)
    .[a1].CurrentRegion.Offset(3, 0).ClearContents
    If n > 0 Then .[a4].Resize(n, 15) = Brr
End With
MsgBox Timer - Tm
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

wzd28

sam-wang 发表于 2022-1-14 12:30
請測試看看，謝謝
Sub test()
Dim Arr, xD, Brr(1 To 200, 1 To 15), a$, a1$, fs, f, fc, f1

老师，能不能帮忙在“月度采购计划汇总表”里面，点击“拆分”按钮，把汇总表按类别拆分到一个工作簿里面（不是分开几工作簿），已做一个“拆分类别模板”供参考，方便采购分类购买物品，谢谢！

    汇总拆分.rar (43.1 KB, 下载次数: 3)

2022-1-17 10:57 上传

点击文件名下载附件

sam-wang

wzd28 发表于 2022-1-17 10:58
老师，能不能帮忙在“月度采购计划汇总表”里面，点击“拆分”按钮，把汇总表按类别拆分到一个工作簿里面 ...

請測試看看，謝謝

wzd28

sam-wang 发表于 2022-1-17 20:34
請測試看看，謝謝

老师，谢谢你帮忙，拆分后出现几个问题，能否设置一下，谢谢！
1、拆分表格文件名显示“╊だ”，能否改为“采购明细拆分”。
2、拆分后的每个表格第一行都是“Purchase plan”，没有显示“月度采购计划汇总表”。
3、拆分后的每个表格“采购预算金额”总金额Total能否改为“合计”。
4、拆分后的每个表格序号能否重新排序。


   

wzd28

sam-wang 发表于 2022-1-17 20:34
請測試看看，謝謝

还有就是总金额Total金额合计要显示数字小数点后2为数，谢谢！

sam-wang

wzd28 发表于 2022-1-17 21:28
老师，谢谢你帮忙，拆分后出现几个问题，能否设置一下，谢谢！
1、拆分表格文件名显示“╊だ”，能否改 ...

已更新請再測試看看，謝謝

Sub Sorting()
Dim Arr, xD, s%, n%, i&, i2&
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Tm = Timer
Arr = Sheets(1).[a1].CurrentRegion
Set xD = CreateObject("scripting.dictionary")
For i = 4 To UBound(Arr)
    If xD.exists(Arr(i, 2)) Then
        Set xD(Arr(i, 2)) = Union(xD(Arr(i, 2)), Rows(i))
    Else
        Set xD(Arr(i, 2)) = Union(Rows(2), Rows(3), Rows(i))
    End If
Next
Workbooks.Add
For i = Sheets.Count To 2 Step -1: Sheets(i).Delete: Next
For i = 0 To xD.Count - 1
    With Sheets(i + 1)
        xD.items()(i).Copy Sheets(i + 1).[a1]
        .Name = xD.keys()(i)
    End With
    If Sheets.Count < xD.Count Then ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
Next
For i = 1 To Sheets.Count
    With Sheets(i)
        .Rows("1:1").Insert
        .[a1] = "月度采购计划汇总表"
        .Range(.Cells(1, 1), .Cells(1, 22)).MergeCells = True
        .Range(.Cells(1, 1), .Cells(1, 22)).HorizontalAlignment = xlCenter
        Arr = .[a1].CurrentRegion
        For i2 = 4 To UBound(Arr): n = n + 1: Arr(i2, 1) = n: s = s + Arr(i2, 20): Next
        .Range("a1").Resize(UBound(Arr), 1) = Arr: .Cells(n + 4, 19) = "合计"
        .Cells(n + 4, 20) = s: .Cells(n + 4, 20).NumberFormatLocal = "0.00_ "
        .Range(.Cells(n + 4, 1), .Cells(n + 4, 22)).Borders.LineStyle = xlContinuous
        n = 0: s = 0
    End With
Next
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "采购明细拆分"
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox Timer - Tm
End Sub