遍历汇总加求和

vleexhya

本人找了几个案例，堵点太多，没有搞定。希望老师们能给予帮助，多谢老师们！




在实际工作中，做了一个部分单元格保护起来的模板，保护密码是123，希望运行完宏再保护起来。

日常操作是，复制模板填写内容然后完成一张sheet表的工作，然后希望将此sheet表保存为PDF，并遍历各sheet表的部分内容汇总到一张表里，然后弹出提醒（类数据透视表）：字段3对应的字段9，字段10的合计数是多少。


具体见附件！
多谢老师们帮助！

洋务德雷

为什么不直接把数据都复制粘贴或录入数据直接录入到汇总表不就可以了吗？需要分开查询的时候，再单独提取某一天录入的内容不就简单了？

chzsh

Sub 遍历工作表()
k1 = Sheets("汇总").Range("a65536").End(xlUp).Row
If k1 > 1 Then
    Sheets("汇总").Range("a2:n" & k1).Delete
End If
For Each sh In Worksheets    '数组
    irow = Sheets("汇总").Range("a65536").End(xlUp).Row   
    If sh.Name <> "汇总" And sh.Name <> "模板" Then    '指定不参与循环的工作表名称，可一个或多个，自行增减
        sh.Range("a8:n17").Copy
        Sheets("汇总").Range("a" & irow + 1).PasteSpecial Paste:=xlPasteValues
    End If
Next
Sheets("汇总").[a1].CurrentRegion.Borders.LineStyle = 1
Call hb
End Sub


Sub hb()
Set d = CreateObject("scripting.dictionary")
With Sheets("汇总")
   r = .Cells(.Rows.Count, 1).End(3).Row
   arr = .Range("c1:j" & r)
   For i = 2 To UBound(arr)
       s = arr(i, 1)
      If Not d.exists(s) Then
        d(s) = Array(Val(arr(i, 7)), arr(i, 8))
      Else
        d(s) = Array(Val(arr(i, 7)) + d(s)(0), Val(arr(i, 8)) + d(s)(1))
      End If
   Next
End With
  k = d.keys
  t = d.items
   For i = 1 To UBound(k) + 1
        MsgBox arr(1, 1) & "     " & k(i - 1) & "     " & arr(1, 7) & "    合计   " & t(i - 1)(0) & "     " & arr(1, 8) & "    合计   " & t(i - 1)(1)
   Next
End Sub

chzsh

请试一下附件吧

suiyuanban

供参考。。。。

tanglf188

这么多热心坛友，支持一下

gwjkkkkk

Sub TEST()
    Dim arr, vData, i&, j&, R&, dic As Object
    Dim strTxt$, wks As Worksheet, vKey
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    arr = Range(Sheets("汇总").[A1], Sheets("汇总").Cells(1, Columns.Count).End(xlToLeft))
    ReDim vData(1 To 10000, 1 To UBound(arr, 2)): R = R + 1
    For i = 1 To UBound(arr, 2)
       vData(R, i) = arr(R, i)
    Next i
   
    For Each wks In Sheets
       If wks.Name Like "*-*-*" Then
          With wks
             If .ProtectContents = True Then .Unprotect (123)
               arr = .[A7].CurrentRegion
               For i = 2 To UBound(arr)
                   R = R + 1
                   For j = 1 To UBound(arr, 2)
                      vData(R, j) = arr(i, j)
                   Next j
                   vKey = vData(R, 3)
                   If Not dic.exists(vKey) Then
                      dic(vKey) = Array(vData(R, 9), vData(R, 10))
                      Else
                      dic(vKey) = Array(dic(vKey)(0) + vData(R, 9), dic(vKey)(1) + vData(R, 10))
                   End If
               Next i
             If .ProtectContents = False Then .Protect (123)
          End With
       End If
    Next
   
    Cells.Clear
    [A1].Resize(R, UBound(vData, 2)) = vData
    With [A1].CurrentRegion
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Rows(1).Font.Bold = True
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
   
    For Each vKey In dic.keys
      strTxt = strTxt & vbCrLf & vKey & "：" & vbCrLf & vData(1, 9) & "：" & Format(dic(vKey)(0), "#,###.00") & vbCrLf & vData(1, 10) & "：" & Format(dic(vKey)(1), "#,###.00")
    Next
    strTxt = strTxt & vbCrLf & vbCrLf & "pdf文件生成在当前目录中"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\1"
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
    MsgBox strTxt
End Sub

gwjkkkkk

请楼主参考附件。。。

vleexhya

gwjkkkkk 发表于 2022-12-17 18:26
请楼主参考附件。。。

多谢帮助！我下载运行是出现错误提示。

vleexhya

suiyuanban 发表于 2022-12-17 17:57
供参考。。。。

多谢，你这个提示信息里的合计数错误，另外，宏是放在以日期命名的sheet表里的，最关键是在以日期命名的sheet表里运行宏的时候，保存为PDF的是该sheet表，不是汇总表。