汇总问题

小女孩

把sheet2汇总成sheet1的格式，我分类汇总也弄不成那样的格式，哪位老师帮我弄一下，十分感谢！！！ 求助.rar (256.53 KB, 下载次数: 15)

2024-7-20 09:30 上传

点击文件名下载附件

3190496160

3190496160

字典的基础应用
求助.rar (311.14 KB, 下载次数: 16)

2024-7-20 10:02 上传

点击文件名下载附件

戎马书生222

Sub abey()
Dim i&, j&, k&
Dim arr, brr()
Set d = VBA.CreateObject("scripting.dictionary")

With Sheets("sheet2")
    arr = .Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 3)
   For i = 1 To UBound(arr)
        kw = arr(i, 1) & "," & arr(i, 2)
        If Not d.exists(kw) Then
            n = n + 1
            d(kw) = n
            brr(n, 1) = Split(kw, ",")(0)
            brr(n, 2) = Split(kw, ",")(1)
            brr(n, 3) = arr(i, 3)
        Else
            r = d(kw)
            brr(n, 3) = brr(n, 3) + arr(i, 3)
        End If
   Next
End With
With Sheets("sheet1")
[a1:c10000].ClearContents
[a1].Resize(n, 3) = brr
End With
End Sub

cnmlgb9998

用PQ解决，香不香？？？？？？？？？？？？？

戎马书生222

这个简单。

戎马书生222

Sub abey()
Dim i&, j&, k&
Dim arr, brr()
Set d = VBA.CreateObject("scripting.dictionary")

With Sheets("sheet2")
    arr = .Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 3)
   For i = 1 To UBound(arr)
        kw = arr(i, 1) & "," & arr(i, 2)
        If Not d.exists(kw) Then
            n = n + 1
            d(kw) = n
            brr(n, 1) = Split(kw, ",")(0)
            brr(n, 2) = Split(kw, ",")(1)
            brr(n, 3) = arr(i, 3)
        Else
            r = d(kw)
            brr(n, 3) = brr(n, 3) + arr(i, 3)
        End If
   Next
End With
With Sheets("sheet1")
[a1:c10000].ClearContents
[a1].Resize(n, 3) = brr
End With
End Sub

chxw68

1. Sub test()
   
2.     Dim sql As String
   
3.     Dim mybook As String
   
4.     Dim cnn As Object
   
5.     Dim rs As Object
   
6.     Set cnn = CreateObject("adodb.connection")
   
7.     Set rs = CreateObject("adodb.recordset")
   
8.     mybook = ThisWorkbook.FullName
   
9.     With cnn
   
10.         If Application.Version = "11.0" Then
    
11.             .Provider = "microsoft.jet.oledb.4.0"
    
12.             .ConnectionString = "extended properties=""excel 8.0;HDR=YES;IMEX=1"";data source=" & mybook
    
13.         Else
    
14.             .Provider = "microsoft.ACE.oledb.12.0"
    
15.             .ConnectionString = "extended properties=""excel 12.0;HDR=YES;IMEX=1"";data source=" & mybook
    
16.         End If
    
17.         .Open
    
18.     End With
    
19.     sql = "select 药品,医生,sum(数量) as 数量 from [sheet2$a1:c] group by 药品,医生"
    
20.     rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
21.     With Worksheets("sheet1")
    
22.         .Cells.Delete
    
23.         For j = 0 To rs.Fields.Count - 1
    
24.             .Cells(1, j + 1) = rs.Fields(j).Name
    
25.         Next
    
26.         .Range("a2").CopyFromRecordset rs
    
27.     End With
    
28. End Sub
    

复制代码

chxw68

数据整齐规范，ADO也方便。

Qs18

Sub qs()
Dim arr, brr, i, dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheet2.Range("a1").CurrentRegion.Value
ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 2 To UBound(arr)
    s = arr(i, 1) & arr(i, 2)
    If Not dic.exists(s) Then
        M = M + 1
        dic(s) = M
        brr(M, 1) = arr(i, 1): brr(M, 2) = arr(i, 2): brr(M, 3) = arr(i, 3)
    Else
        rw = dic(s)
        brr(rw, 3) = brr(rw, 3) + arr(i, 3)
   
    End If
    Next
Sheet1.Range("a2").Resize(M, 3) = brr
Set dic = Nothing
End Sub