分类汇总

wangchs79

如何修改下面VBA实现上传附件效果

Sub fz()

    Dim i&, Myr&, Arr

    Dim d, k, t

    Set d = CreateObject("Scripting.Dictionary")

     [d2:f1000].ClearContents

    Myr = Sheet1.[a65536].End(xlUp).Row

    Arr = Sheet1.Range("a1:c" & Myr)

    For i = 2 To UBound(Arr)

        ss = Arr(i, 1) & vbTab & Arr(i, 2)

        d(ss) = d(ss) + Arr(i, 3)

    Next

    k = d.keys

    t = d.items

    For N = LBound(k) To UBound(k)

       Cells(N + 2, 4).Resize(1, 3) = Split(k(N), vbTab)

    Next

    [f2].Resize(d.Count, 1) = Application.Transpose(t)

    Set d = Nothing

End Sub

opiona

1.     Set SH0 = Worksheets("Sheet1")
   
2.     Set SH1 = Worksheets("Sheet2")
   
3.    
   
4.     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
   
5.     StrSQL = ""
   
6.     StrSQL = StrSQL & "SELECT 电料名称,型号规格"
   
7.     StrSQL = StrSQL & ",SUM(数量) AS 数量"
   
8.     StrSQL = StrSQL & ",MAX(面价) AS 面价"
   
9.     StrSQL = StrSQL & ",MAX(品牌) AS 品牌"
   
10.     StrSQL = StrSQL & " FROM [" & SH0.Name & "$A3:H]"
    
11.     StrSQL = StrSQL & " WHERE NOT 电料名称 IS NULL AND LEN(电料名称)>0"
    
12.     StrSQL = StrSQL & " AND INSTR('小计,人工,企管费,利润,税金,合计,柜号,电料名称',电料名称)=0"
    
13.     StrSQL = StrSQL & " GROUP BY  电料名称,型号规格"
    
14.    
    
15.     SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
    
16.     SH1.Range("A1:Z1048576").ClearContents
    
17.     SH1.Range("A1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR

复制代码

opiona

数据不太规范，对付用吧： QQ14885553.rar (29.57 KB, 下载次数: 24)

2018-7-20 08:15 上传

点击文件名下载附件

wangchs79

非常感谢！

wangchs79

你太牛了！