请教如何汇总各单位数据行

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.18
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("汇总表")
   
6.     With sh
   
7.         r = .Columns("b:b").Find("合计", , , , , 1).Row
   
8.         brr = .UsedRange
   
9.         .Range("c4:f" & r - 1) = ""
   
10.     End With
    
11.     For i = 4 To UBound(brr)
    
12.         s = brr(i, 2)
    
13.         If Val(brr(i, 1)) Then
    
14.             d(s) = i
    
15.         End If
    
16.     Next
    
17.     p = ThisWorkbook.Path & "\收回文件"
    
18.     For Each f In Fso.GetFolder(p).Files
    
19.         If f.Name Like "*.xls*" Then
    
20.             fn = Fso.GetBaseName(f)
    
21.             Set wb = Workbooks.Open(f, 0)
    
22.             With wb.Sheets(1)
    
23.                 arr = .UsedRange
    
24.                 wb.Close False
    
25.             End With
    
26.             For i = 4 To UBound(arr)
    
27.                 s = arr(i, 2)
    
28.                 If Val(arr(i, 1)) Then
    
29.                     If Val(arr(i, 3)) Then
    
30.                         For j = 3 To UBound(arr, 2)
    
31.                             brr(d(s), j) = arr(i, j)
    
32.                         Next
    
33.                     End If
    
34.                 End If
    
35.             Next
    
36.         End If
    
37.     Next f
    
38.     sh.UsedRange = brr
    
39.     sh.Cells(r, 3).Resize(1, 3).FormulaR1C1 = "=SUM(R4C:R" & r - 1 & "C)"
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    
43. 
    

复制代码

fzxba

wsx22 发表于 2024-3-18 13:13
fzxba，向老师，您好！您提供5楼汇总代码，vbaSQL运用太精彩，请问如果工作表（单位）数超49个汇总，代码显 ...

Sub test0() '最好自己发帖，不要寄生在别人的帖子中。  可先列出单位，别重复，也可不列出，自动生成。 代码仅针对楼主附件
  
  Dim ar(), br, i As Long, rowSize As Long
  Dim Conn As Object, rs As Object, Dic As Object, Dict As Object
  Dim s As String, p As String, f As String
  Dim strConn As String, SQL As String
  
  Sheet1.Activate
  Application.ScreenUpdating = False
  
  Set Dic = CreateObject("Scripting.Dictionary")
  Set Dict = CreateObject("Scripting.Dictionary")
  Set Conn = CreateObject("ADODB.Connection")
  Set rs = CreateObject("ADODB.Recordset")
  
  With Range("A1").CurrentRegion.Resize(1003, 6) '假设有1000个单位,6个统计项。
    .Offset(3, 2).ClearContents                  '可这样，.Offset(3).ClearContents 清空后全自动 。
    ar = Intersect(.Offset(0), .Offset(3)).Value
  End With
  
  For i = 1 To UBound(ar)
    If Len(Trim(ar(i, 2))) Then
      rowSize = rowSize + 1
      Dict.Add Trim(ar(i, 2)), rowSize           '特意这样写，出错则意味着 单位重复。
    End If
  Next
  
  s = "Excel 12.0;HDR=YES;Database="
  If Application.Version < 12 Then
    s = Replace(s, "12.0", "8.0")
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
  Else
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
  End If
  Conn.Open strConn & ThisWorkbook.FullName
  
  p = ThisWorkbook.Path & "\收回文件\"
  f = Dir(p & "*.xls*")
    SQL = "SELECT * FROM [" & s & p & "[.f]].[$A3:F] WHERE `学   校` IS NOT NULL"
  Do
    If ThisWorkbook.FullName <> p & f Then
      Dic.Add Replace(SQL, "[.f]", f), vbNullString
      If Dic.Count = 49 Then
        Set rs = Conn.Execute(Join(Dic.Keys, " UNION ALL "))
        br = rs.GetRows
        Processingdata ar, br, Dict, rowSize
        Dic.RemoveAll
      End If
    End If
    f = Dir()
  Loop While Len(f)
  
  If Dic.Count Then
    Set rs = Conn.Execute(Join(Dic.Keys, " UNION ALL "))
    br = rs.GetRows
    Processingdata ar, br, Dict, rowSize
    Dic.RemoveAll
  End If
  
  Range("A4").Resize(UBound(ar), UBound(ar, 2)) = ar
  
  rs.Close
  Set rs = Nothing
  Conn.Close
  Set Conn = Nothing
  Set Dict = Nothing
  Set Dic = Nothing
  
  Application.ScreenUpdating = True
  Beep
End Sub

Function Processingdata(ar, br, Dict As Object, rowSize As Long)
  Dim i As Long, j As Long, posRow As Long, posCol As Long, s As String
  For i = 0 To UBound(br, 2)
    s = Trim(br(1, i))
    If Not Dict.Exists(s) Then
      rowSize = rowSize + 1
      Dict.Add s, rowSize
      For j = 0 To 1
        ar(rowSize, 1 + j) = br(j, i)
      Next
    End If
    posRow = Dict(s)
    For j = 2 To UBound(br) - 1
      If Not IsNull(br(j, i)) Then ar(posRow, 1 + j) = ar(posRow, 1 + j) + Val(br(j, i)) '各单位数值唯一，不要串填，否则数值累加。
    Next
    ar(posRow, 1 + j) = ar(posRow, 1 + j) & br(j, i)    '各单位备注唯一，不要串填，否则字符串叠加。
  Next
End Function

fzxba

wsx22 发表于 2024-3-18 13:13
fzxba，向老师，您好！您提供5楼汇总代码，vbaSQL运用太精彩，请问如果工作表（单位）数超49个汇总，代码显 ...

见模块2.zip (39.01 KB, 下载次数: 10)

2024-3-18 14:46 上传

点击文件名下载附件

wsx22

谢谢！向老师！