VBA 提取多列数据并排序汇总

jiminyanyan

不知道为什么 发表于 2018-8-4 21:14
3楼的附件我电脑运行不了，jimin老师。看样子是硬件也不想让我进步了，呵呵。

和硬件关系不大，估计是office 不是完整版，或没装全。

不知道为什么

jiminyanyan 发表于 2018-8-4 21:20
和硬件关系不大，估计是office 不是完整版，或没装全。

哈哈，想给自己个偷懒的理由也被你看穿了！

jiminyanyan

不知道为什么 发表于 2018-8-4 21:22
哈哈，想给自己个偷懒的理由也被你看穿了！

SQL还是比较简单的，好比，你到饭店说：给我来盘回锅肉，具体怎么烧，你自己不用管的。用数组就要管细节了。

不知道为什么

chunyanghua2002 发表于 2018-8-4 21:14
附件如图 谢谢！

真心劝你写代码的时间可以数据透视表就可以了，效率还高，当然学习目的另当别论了，譬如我，闲着就当练习了。

不知道为什么

jiminyanyan 发表于 2018-8-4 21:27
SQL还是比较简单的，好比，你到饭店说：给我来盘回锅肉，具体怎么烧，你自己不用管的。用数组就要管细节 ...

jim老师你很厉害啊，我刚端起酒杯，你就给我来个吃饭的比方。哈哈

chaohuahch

我写的代码效果及代码如下：

1. Sub 查询()
   
2. Dim arr, i%, j%, Str As String
   
3. Dim dic As Object
   
4. arr = Sheets("源数据").Range("a2").CurrentRegion
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. For i = 2 To UBound(arr)
   
7.    Str = arr(i, 1) & arr(i, 2)
   
8.    If Not dic.exists(Str) Then
   
9.    Set dic(Str) = CreateObject("scripting.dictionary")
   
10.    dic(Str)(arr(i, 3)) = arr(i, 5)
    
11.    Else
    
12.        If dic(Str).exists(arr(i, 3)) Then
    
13.           dic(Str)(arr(i, 3)) = dic(Str)(arr(i, 3)) + arr(i, 5)
    
14.        Else
    
15.           dic(Str)(arr(i, 3)) = arr(i, 5)
    
16.        End If
    
17.     End If
    
18. Next i
    
19. k = dic("2014SUPPLY1").items
    
20. 
    
21. With Sheets("目标格式")
    
22.      Str = .Range("b1").Value & .Range("b2").Value
    
23.      If dic(Str).Count < 6 Then
    
24.      .Range("a5:b10").ClearContents
    
25.      .Range("a5").Resize(dic(Str).Count, 1) = WorksheetFunction.Transpose(dic(Str).keys)
    
26.      .Range("B5").Resize(dic(Str).Count, 1) = WorksheetFunction.Transpose(dic(Str).items)
    
27.      .Range("a5:b10").Sort Key1:=.Range("b5"), Order1:=xlDescending
    
28.      .Range("a11") = "Total": .Range("b11") = WorksheetFunction.Sum(dic(Str).items)
    
29.      Else
    
30.       .Range("f:f").ClearContents: .Range("g:g").ClearContents
    
31.       .Range("f1").Resize(dic(Str).Count, 1) = WorksheetFunction.Transpose(dic(Str).keys)
    
32.       .Range("g1").Resize(dic(Str).Count, 1) = WorksheetFunction.Transpose(dic(Str).items)
    
33.       .Range("f:g").Sort Key1:=.Range("g1"), Order1:=xlDescending
    
34.       .Range("a5") = .Range("f1"): .Range("b5") = .Range("g1")
    
35.       .Range("a6") = .Range("f2"): .Range("b6") = .Range("g2")
    
36.       .Range("a7") = .Range("f3"): .Range("b7") = .Range("g3")
    
37.       .Range("a8") = .Range("f4"): .Range("b8") = .Range("g4")
    
38.       .Range("a9") = .Range("f5"): .Range("b9") = .Range("g5")
    
39.       .Range("a11") = "Total": .Range("b11") = WorksheetFunction.Sum(dic(Str).items)
    
40.       .Range("a10") = "OTHERS"
    
41.        arr = .Range("b5:b9")
    
42.       .Range("b10") = .Range("b11") - WorksheetFunction.Sum(arr)
    
43.       .Range("f:f").ClearContents: .Range("g:g").ClearContents
    
44.      End If
    
45. End With
    
46. 
    
47. End Sub
    

复制代码

jiangxiaoyun

用透视表不是更简单方便吗？

iwangyi

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("c1:c2")) Is Nothing Then
Range("b3:c100").Clear
'引用MICROSOFT ACTIVEX DATA OBJECTS 2.XLIBRARY
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
NF = Sheet2.Cells(1, 3): GYS = Sheet2.Cells(2, 3)
cn.Open "PROVIDER=MICROSOFT.JET.OLEDB.4.0;EXTENDED PROPERTIES=EXCEL 8.0;DATA SOURCE=" & ThisWorkbook.FullName
Sql = "select 客户,金额CNY from(select * from [源数据$A2:E] WHERE 年份= " & NF & " AND 供应商='" & GYS & "' ORDER BY 金额CNY DESC)"
n = Sheet2.Range("b65536").End(xlUp).Row
rs.Open Sql, cn, 3, 2
X = rs.RecordCount
With Sheet2
If X <= 5 Then
.Range("B" & n + 2).Resize(, 2) = Array("客户", "金额CNY")
.Range("b" & n + 3).CopyFromRecordset cn.Execute(Sql)
SQLL = "SELECT SUM(金额CNY) FROM (select 客户,金额CNY from(select * from [源数据$A2:E] WHERE 年份= " & NF & " AND 供应商='" & GYS & "' ORDER BY 金额CNY DESC))"
.Cells(n + 1 + 8, 2) = "Total"
.Range("C" & n + 1 + 8).CopyFromRecordset cn.Execute(SQLL)
Else
.Cells(n + 2, 2) = "客户": .Cells(n + 2, 3) = "金额CNY"
SQLL = "select 客户,金额CNY from(select TOP 5 * from [源数据$A2:E] WHERE 年份= " & NF & " AND 供应商='" & GYS & "' ORDER BY 金额CNY DESC)"
.Range("B" & n + 3).CopyFromRecordset cn.Execute(SQLL)
.Cells(n + 1 + 7, 2) = "OTHERS"
.Cells(n + 1 + 8, 2) = "Total"
SQLLL = "select SUM(金额CNY) from(select * from [源数据$A2:E] WHERE 年份= " & NF & " AND 供应商='" & GYS & "' ORDER BY 金额CNY DESC)"
.Range("C" & n + 1 + 8).CopyFromRecordset cn.Execute(SQLLL)
SQLLLL = "select sum(金额CNY) from(select TOP 5 * from [源数据$A2:E] WHERE 年份= " & NF & " AND 供应商='" & GYS & "' ORDER BY 金额CNY DESC)"
.Cells(n + 1 + 7, 3).CopyFromRecordset cn.Execute(SQLLLL)
.Cells(n + 1 + 7, 3) = .Cells(n + 1 + 8, 3) - .Cells(n + 1 + 7, 3)
End If
End With
End If
End Sub

iwangyi

附件------------

iwangyi

没有想到简单的方法，若要用ADO 须前期绑定，要取记录数进行判定及汇总；而后期绑定，不论怎么设置记录指针类型，RS.RECORDCOUNT记录个数都显示-1.