按表头汇总数据

czl103

如附件所示，想达到的效果是，将1-4月的话费都汇总到汇总表中，结果却是只汇总了文件夹下第一个工作表的数据，烦请哪位高手修改一下代码，谢谢
最好简单解释一下，哪儿写的不对，不胜感激！

liucf

加一个循环就行
Sub 按表头汇总()
  Dim MyPath$, MyName$, sh As Workbook, i&, Arr, Brr(1 To 100, 1 To 2) ' 定义变量
  Dim c1, c2, k, sr As String, S As Worksheet
  Set d = CreateObject("Scripting.Dictionary") '定义字典
  Application.ScreenUpdating = False '关闭屏幕刷新，提高速度
  Application.DisplayAlerts = False
  MyPath = ThisWorkbook.Path & "\" '获得当前工作簿所在的地址
  MyName = Dir(MyPath & "*.xls*") '获得文件夹内的文件名
  Do While MyName <> "" '开始在文件夹内的文件中开始循环
    If MyName <> ThisWorkbook.Name Then '文件名不等于当前工作簿时进行以下操作
      Set sh = GetObject(MyPath & MyName) '打开工作簿
      For Each S In sh.Sheets
        Arr = S.Range("A1").CurrentRegion '将打开的工作簿A1单元格所在的区域放入数组
        For j = 1 To UBound(Arr, 2)
          If Arr(1, j) = "对方号码" Then c1 = j '"分期数" ------需更新
          If Arr(1, j) = "实收通信费" Then c2 = j '"综合费用合计"------需更新
        Next
        For i = 2 To UBound(Arr) '从数组的第二项开始循环，因为第一项为标题
          If Arr(i, c1) <> "" Then
            If d.exists(Arr(i, c1)) Then '判断在不在字典内，如果在进行以下操作
              k = d(Arr(i, c1)) '返回字典内的关键字所在的位置，也就是返回二维数组的行号
              Brr(k, 2) = Brr(k, 2) + Arr(i, c2) '将关键字对应的项目求和'
            Else '如果字典内没有进行以下操作
              m = m + 1 '定义一个新位置
              d(Arr(i, c1)) = m '将这个关键放入新位置,可以理解为放入一个新的二维数组,m为数组的行号
              Brr(m, 1) = Arr(i, c1) '数组第一列为名称                                         "期"------需更新
              Brr(m, 2) = Arr(i, c2) '数组第二列为对应的数据
            End If
          End If
        Next
      Next
      Windows(MyName).Visible = True
      Workbooks(MyName).Close True '关闭打开的工作簿
    End If
    MyName = Dir '获得下一个文件名
  Loop
  With ThisWorkbook.ActiveSheet
    .Range("A1") = "对方号码:": .Range("B1") = "实收通信费" '"分期数:"------需更新
    .Range("A2").Resize(UBound(Brr), 2) = Brr '将刚才的统计数据放在单元格内
    k = .Range("A1048576").End(xlUp).Row + 1
    .Cells(k, 1) = "合计:"
    .Cells(k, 2) = WorksheetFunction.Sum(.Range(Cells(2, 2).Address, Cells(k, 2).Address))
  End With
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

lsc900707

没有遍历每个工作簿中的工作表，默认只汇总第一个工作表的数据。

czl103

lsc900707 发表于 2018-3-30 17:03
没有遍历每个工作簿中的工作表，默认只汇总第一个工作表的数据。

如何遍历所有工作表，还请指教一二

lsc900707

czl103 发表于 2018-3-30 17:06
如何遍历所有工作表，还请指教一二

代码已修改，详见附件：

1249994139

Sub test()
    Dim Dic, Mp$, Fs$, Wb As Workbook, x%, c%, C1%, C2%, R&, k&, arr1, arr2(1 To 100, 1 To 2), kk%, kkk%, T#
    T = Timer
    Application.ScreenUpdating = False
    Set Dic = CreateObject("scripting.dictionary")
    Mp = ThisWorkbook.Path & "\"
    Fs = Dir(Mp & "*.xlsx")
    Do
        Set Wb = Workbooks.Open(Mp & Fs)
        With Wb
            kk = kk + 1
            For x = 1 To .Sheets.Count
                kkk = kkk + 1
                arr1 = .Sheets(x).Range("A1").CurrentRegion
                For c = 1 To UBound(arr1, 2)
                    If arr1(1, c) = "对方号码" Then C1 = c
                    If arr1(1, c) = "实收通信费" Then C2 = c
                Next c
                For R = 2 To UBound(arr1)
                    If VBA.IsNumeric(arr1(R, C1)) = True Then
                        If Not Dic.exists(arr1(R, C1)) Then
                            k = k + 1
                            Dic(arr1(R, C1)) = k
                            arr2(k, 1) = arr1(R, C1)
                            arr2(k, 2) = arr1(R, C2)
                        Else
                            arr2(Dic(arr1(R, C1)), 2) = arr2(Dic(arr1(R, C1)), 2) + arr1(R, C2)
                        End If
                    End If
                Next R
            Next x
            .Close False
        End With
        Set Wb = Nothing
        
        Fs = Dir
    Loop While Fs <> ""
    With ThisWorkbook.Sheets(1)
        .UsedRange.Offset(1).Clear
        .[a2].Resize(UBound(arr2), 2) = arr2
    End With
    Application.ScreenUpdating = True
    Cells(k + 1, 1) = "总计"
    Cells(k + 1, 2) = Application.WorksheetFunction.Sum(Application.Index(arr2, 0, 2))
    VBA.MsgBox "亲，已经汇总了 " & kk & " 个工作簿，计 " & kkk & " 张工作表，" & Chr(10) & "累计用时" & Format(Timer - T, "0.000秒"), 16 * 4, "友情提醒"
End Sub

1249994139

代码详见附件

czl103

liucf 发表于 2018-3-30 17:31
加一个循环就行
Sub 按表头汇总()
  Dim MyPath$, MyName$, sh As Workbook, i&, Arr, Brr(1 To 100, 1 T ...

可以了 谢谢

czl103

lsc900707 发表于 2018-3-30 17:36
代码已修改，详见附件：

谢谢版主。。。

czl103

1249994139 发表于 2018-3-30 19:22
代码详见附件

厉害  O(∩_∩)O谢谢