如何将数据表中的各项信息按汇总表格式汇总

sxdmsz

如何将数据表中的各项信息按汇总表格式汇总，数据中不同内容牵涉到的名字不同，工资不同，如何根据姓名进行自动汇总，求助老师，谢谢。 1.rar (9.2 KB, 下载次数: 17)

2024-2-4 10:28 上传

点击文件名下载附件

gwjkkkkk

请参考附件。。。

yynrzwh

1.rar (20.29 KB, 下载次数: 14)

2024-2-4 11:14 上传

点击文件名下载附件

limonet

关键字：union=left join

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    For i = 2 To 7 Step 2
        StrSQL = StrSQL & " Union Select * From [数据$" & Cells(2, i).Address(0, 0) & ":" & Left(Cells(2, i).Address(0, 0), 1) & "] Where F1<>''"
    Next i
    StrSQL = Mid(StrSQL, 8)
    For i = 2 To 7 Step 2
        StrSQL = "Select a.*,b.F2 From (" & StrSQL & ")a Left Join [数据$" & Left(Cells(2, i).Address(0, 0), 1) & ":" & Left(Cells(2, i + 1).Address(0, 0), 1) & "]b On a.F1=b.F1"
    Next i
    Range("B4").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

代码测试通过。。。

1. Sub ykcbf()   '//2024.2.4
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set d2 = CreateObject("Scripting.Dictionary")
   
7.     With Sheets("数据")
   
8.         r = .UsedRange.Find("*", searchdirection:=2).Row
   
9.         c = .UsedRange.Columns.Count
   
10.         arr = .[a1].Resize(r, c)
    
11.     End With
    
12.     For i = 2 To UBound(arr)
    
13.         For j = 2 To UBound(arr, 2) Step 2
    
14.             If arr(i, j) <> Empty Then
    
15.                 s = arr(i, j) & "|" & arr(1, j + 1)
    
16.                 d(s) = arr(i, j + 1)
    
17.                 s = arr(i, j)
    
18.                 d1(s) = ""
    
19.                 s = arr(1, j + 1)
    
20.                 d2(s) = ""
    
21.             End If
    
22.         Next
    
23.     Next
    
24.     ReDim zrr(1 To d1.Count, 1 To 2)
    
25.     For Each k In d1.keys
    
26.         m = m + 1
    
27.         zrr(m, 1) = m
    
28.         zrr(m, 2) = k
    
29.     Next
    
30.     With Sheets("汇总")
    
31.         .[a3:z15] = ""
    
32.         .[a3:b3] = Array("序号", "姓名")
    
33.         .[a4].Resize(m, 2) = zrr
    
34.         .[c3].Resize(1, d2.Count) = d2.keys
    
35.         arr = .Range("a3:z15")
    
36.         For i = 2 To UBound(arr)
    
37.             For j = 3 To UBound(arr, 2)
    
38.                 s = arr(i, 2) & "|" & arr(1, j)
    
39.                 If d.Exists(s) Then
    
40.                    arr(i, j) = d(s)
    
41.                 End If
    
42.             Next
    
43.         Next
    
44.         .Range("a3:z15") = arr
    
45.     End With
    
46.     Set d = Nothing
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

fzxba

1. Sub test1() '练习了，也就发一下。
   
2.   Dim ar, br, Conn As Object, rs As Object
   
3.   Dim strConn As String, strSQL As String, strTab As String, i As Long
   
4.   Application.ScreenUpdating = False
   
5.   Set Conn = CreateObject("ADODB.Connection")
   
6.   If Application.Version < 12 Then
   
7.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
   
8.   Else
   
9.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
   
10.   End If
    
11.   Conn.Open strConn & ThisWorkbook.FullName
    
12.   With Sheet2
    
13.     ar = Application.Rept(.Range("A1").CurrentRegion.Rows(1), 1)
    
14.     br = Array(ar(2), "项目", "金额")
    
15.     For i = 2 To UBound(ar) Step 2
    
16.       strTab = "[" & .Name & "$" & .Range(.Cells(1, i), .Cells(.Rows.Count, i).End(xlUp)).Resize(, 2).Address(0, 0) & "]"
    
17.       strSQL = strSQL & " UNION ALL SELECT `" & ar(i) & "` AS " & br(0) & ",`" & ar(i + 1) & "` AS " & br(2) & ",'" & ar(i + 1) & "' AS " & br(1) & " FROM " & strTab
    
18.     Next
    
19.   End With
    
20.   strSQL = "TRANSFORM SUM(" & br(2) & ") SELECT '' AS 序号," & br(0) & " FROM (" & Mid(strSQL, 12) & ") GROUP BY " & br(0) & " PIVOT " & br(1)
    
21.   Set rs = Conn.Execute(strSQL)
    
22.   With Sheet1.Range("A3")
    
23.     .CurrentRegion.ClearContents
    
24.     For i = 0 To rs.Fields.Count - 1
    
25.       .Offset(, i) = rs.Fields(i).Name
    
26.     Next
    
27.     .Offset(1).CopyFromRecordset rs
    
28.     br = .CurrentRegion.Columns(1)
    
29.     For i = 1 To UBound(br) - 1
    
30.       br(i + 1, 1) = i
    
31.     Next
    
32.     .CurrentRegion.Columns(1) = br
    
33.   End With
    
34.   rs.Close
    
35.   Set rs = Nothing
    
36.   Conn.Close
    
37.   Set Conn = Nothing
    
38.   Application.ScreenUpdating = True
    
39.   Beep
    
40. End Sub

复制代码

清风竹-

Sub 自动汇总()
    Dim arr, d
    Set d = CreateObject("Scripting.Dictionary")
        arr = Sheets("数据").Range("a1").CurrentRegion
     ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 26)
   
    For i = 2 To UBound(arr, 2) Step 2
        For j = 1 To UBound(arr)
            If arr(j, i) <> Empty Then
                If Not d.exists(arr(j, i)) Then
                   n = n + 1
                   brr(n, 1) = n - 1
                   brr(n, 2) = arr(j, i)
                   brr(n, i / 2 + 2) = arr(j, i + 1)
                  d(arr(j, i)) = n
                Else
                   brr(d(arr(j, i)), i / 2 + 2) = arr(j, i + 1)
                End If
            End If
        Next
    Next
    brr(1, 1) = "序号"
       Sheets("汇总").Range("a3").Resize(n, UBound(arr, 2) / 2 + 2) = brr
    Set d = Nothing
    MsgBox "OK！"
End Sub