汇总表增加多一个部门，如何修改VBA

wzd028

在汇总表增加多一个部门（N2），如何修改VBA才能汇总各部门数据，请老师注明在哪里修改，我也可以学习，谢谢！

   


Sub test()  '汇总
  Dim arr, xD, Brr(1 To 2000, 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")
  ActiveSheet.Pictures.Delete
  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
      For Each PIC In .Sheets(1).Pictures
        W = PIC.TopLeftCell.Row
        If W > 2 Then
          PIC.Name = .Sheets(1).Cells(W, "C").Value
          PIC.Copy
          ThisWorkbook.Activate
          Range("V5").Select
          ActiveSheet.Paste
        End If
      Next
      .Close
    End With
    BM = Array("后勤组", "膳食组", "医养服务部", "财务部", "仓库", "品质客服部",  "医疗部", "综合办公室")
    For K = 0 To UBound(BM)
      If InStr(A1, BM(K)) Then DP = 8 + K: Exit For
    Next
    For i = 3 To UBound(arr)
      T = arr(i, 3) & arr(i, 3): If T = "" Then GoTo 97
      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
          For Each PIC In .Pictures
            NM = PIC.Name
            W = Range("C:C").Find(NM).Row
            PIC.Cut
            Cells(W, "V").Select
            ActiveSheet.Paste
          Next
          .[A1].Select
        End With
        MsgBox "用时:    " & Round(Timer - Tm, 2) & "秒"
        Set fs = Nothing: Set f = Nothing: Set fc = Nothing
        Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

xunanming

只有这些不能晓得如何添加,最好能数据的模拟表上传.

wzd028

xunanming 发表于 2023-4-5 12:54
只有这些不能晓得如何添加,最好能数据的模拟表上传.

谢谢老师百忙中帮我解决问题，现已上传附件，请说明在哪里修改，以便日后有增加部门的时候自己修改，谢谢！

sdytsxd991122

应该是不能简单的直接加新部门，可以直接替换不用的部门

吴中泉

wzd028 发表于 2023-4-5 13:14
谢谢老师百忙中帮我解决问题，现已上传附件，请说明在哪里修改，以便日后有增加部门的时候自己修改，谢谢 ...

原代码排版有点乱，加上本人水平有限，费了一点时间进行修改，现分享如下：

比如新插入了一个“保安部”，分五个步骤，如图所示。如若有用，加分鼓励一下。

wzd028

吴中泉 发表于 2023-4-5 15:34
原代码排版有点乱，加上本人水平有限，费了一点时间进行修改，现分享如下：

比如新插入了一个“保安部 ...

谢谢老师帮助，写的非常详细，太有用了。