多条件查询返回多个去重复结果，横向填充后求和

hnmasi

需要以多个条件（最多6个）查询，返回多个结果，横向填充，然后以金额求和。数据量非常大，数据透视表不好使，列项过多不显示，源表10万行左右，跪求大佬帮忙写个VBA，不胜感激。

hnmasi

有没有大佬帮帮忙，找了很多网上和论坛的例子都套不进去，本人VBA小白，实在没办法了

excel海

你的结果是要显示什么?

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
字典的一些案例，楼主可以先参考下

扑腾

抛个媚眼先

excel海

试试看
Sub test()
    Dim i, arr, j, k
    arr = Sheet2.UsedRange
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    With Sheet1
        For i = 2 To UBound(arr)
            If Sheet2.Cells(i, "i") Like "*" & .Cells(2, 2) & "*" And Sheet2.Cells(i, "l") Like "*" & .Cells(2, 3) & "*" _
            And Sheet2.Cells(i, "n") Like "*" & .Cells(2, 4) & "*" And Sheet2.Cells(i, "p") Like "*" & .Cells(2, 5) & "*" _
            And Sheet2.Cells(i, "r") Like "*" & .Cells(2, 6) & "*" Then
             k = k + 1
               For j = 1 To UBound(arr, 2)
                    brr(k, j) = arr(i, j)
               Next
            End If
        Next
'        ReDim Preserve brr(1 To k, 1 To UBound(brr, 2))
        .Cells(5, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    End With
End Sub

hnmasi

excel海 发表于 2020-1-15 23:38
试试看
Sub test()
    Dim i, arr, j, k

老师这个不是我想要的结果呀

13583313392

基本上做成了，还有些细节需要沟通一下

917067811

Sub ttt1()
    Dim isand As Boolean
    Dim rs As Object, dic As Object, arr(), brr()
   
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
   
    Set dic = CreateObject("Scripting.Dictionary")

      
    isand = False
   
    conn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName

   
    Sql = "select 库存组织名称,供应商名称,sum(本币价税合计) from [采购入库明细查询$a:ac] where "

   
    If Sheets("报表").Range("B2").Value <> "" Then
        If isand Then
            Sql = Sql + " and "
        End If
        isand = True
        
        Sql = Sql + "仓库名称 = """ + Sheets("报表").Range("B2").Value + """"
        
    End If
   
    If Sheets("报表").Range("C2").Value <> "" Then
        If isand Then
            Sql = Sql + " and "
        End If
        isand = True
        
        Sql = Sql + "一级分类名称 = """ + Sheets("报表").Range("C2").Value + """"
        
    End If
      
    If Sheets("报表").Range("D2").Value <> "" Then
        If isand Then
            Sql = Sql + " and "
        End If
        isand = True
        
        Sql = Sql + "二级分类名称 = """ + Sheets("报表").Range("D2").Value + """"
        
    End If
   
    If Sheets("报表").Range("E2").Value <> "" Then
        If isand Then
            Sql = Sql + " and "
        End If
        isand = True
        
        Sql = Sql + "三级分类名称 = """ + Sheets("报表").Range("E2").Value + """"
        
    End If
   
    If Sheets("报表").Range("F2").Value <> "" Then
        If isand Then
            Sql = Sql + " and "
        End If
        isand = True
        
        Sql = Sql + "物料名称 = """ + Sheets("报表").Range("F2").Value + """"
        
    End If
   
    Sql = Sql + " group by 库存组织名称,供应商名称  "
   
    Debug.Print Sql
   
    rs.Open Sql, conn
   
    Debug.Print rs.RecordCount
     
    rs.MoveFirst
'    For Each fld In rs.Fields
'        Debug.Print fld.Name,  '列标题
'    Next
'
'    Do Until rs.EOF
'        For Each fld In rs.Fields
'                Debug.Print fld.Value,
'        Next
'
'        rs.MoveNext
'        Debug.Print
'    Loop

    '存入数组
    arr = Application.Transpose(rs.getrows)
   
    Dim m&, k&
   
    ReDim brr(1 To 1000, 1 To 1000)
   
    k = -1
   
    For i = 1 To UBound(arr)
        m = 0
        If dic(arr(i, 1)) = "" Then
            
            k = k + 2

            dic(arr(i, 1)) = 1
            
            brr(k, 1) = arr(i, 1)
            brr(k + 1, 1) = "采购金额小计"
            
            brr(k, 2) = arr(i, 2)
            brr(k + 1, 2) = arr(i, 3)
            
        Else
            m = m + 1
            
            brr(k, m + 2) = arr(i, 2)
            brr(k + 1, m + 2) = arr(i, 3)
            
            
            
        End If
        
        

        
    Next i

    Sheets("报表").Range("A5").Resize(1000, 1000) = brr()
   
   
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

917067811

见附件。。。。。。。。