如何用vba一键汇总多个工作表？

shi7361

如图，想把每个月销售的产品明细，快速合成到一张表格里面，请老师指教一下，想了好几天也没有成功，谢谢！ 汇总.rar (44.02 KB, 下载次数: 16) 2020-11-20 11:48 上传 点击文件名下载附件

chart888

附件呢？

高

附件都不传，那我回答好了：用VBA写些代码，加个按钮或图片。

aidunsoft

用插件实现，也可以用

王宪

借助了中转工作表来合并数据
这个设计只需要在弹出对话框选择数据源文件（可同时多选），不需要打开，加快了速度
因每次选择的数据源文件没法保证是1，2，3.....这样每个月都有，有可能是1，3，4，6等月份数据
所有为保证数据正确，在最后提取数据时，把标题一起提取出来了

王宪

代码如下：

Option Explicit
Dim conn As Object, rs, oblog
Dim tname
Dim sql, sqla, cnstr, i, k, fd, r1, r2, r3, r4, rq
Sub 加载()
    Application.ScreenUpdating = False
    Set conn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    fd = Application.GetOpenFilename("excel文件,*.xlsx", MultiSelect:=True)
    On Error GoTo 100
    If fd = False Then Exit Sub
100:
    With Sheets(2)
         .Cells.Delete
        .Range("A1:F1") = Array("品名", "规格型号", "系列", "销量", "销售收入", "日期")
        For i = 1 To UBound(fd)
            If conn.State <> 0 Then conn.Close
            cnstr = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source =" & fd(i)
            conn.Open cnstr
            Set oblog = Nothing
            Set oblog = CreateObject("adox.catalog")
            oblog.ActiveConnection = cnstr
            tname = Application.Substitute(Left(oblog.Tables(1).Name, InStr(oblog.Tables(1).Name, "$") - 1), "#", ".")
            tname = Right(tname, Len(tname) - 1)
            k = InStr(tname, "（")
            rq = Mid(tname, k + 1, 4) & "年" & Mid(tname, k + 6, 2) & "月."
            sql = "select * from [" & tname & "$A2:E100000] where [品名] not like '%合计%' "
            If rs.State <> 0 Then rs.Close
            rs.Open sql, conn, 3, 3
            r1 = .Range("A100000").End(3).Row + 1
            .Range("A" & r1).CopyFromRecordset rs
            r1 = .Range("A100000").End(3).Row + 1
            r2 = .Range("F100000").End(3).Row + 1
            .Range("F" & r2 & ":F" & r1) = rq
        Next
    End With
    '销量统计
    If conn.State <> 0 Then conn.Close
    cnstr = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source =" & ThisWorkbook.FullName
    conn.Open cnstr
    sql = "transform sum(销量) "
    sql = sql & " select 品名 from [" & Sheets(2).Name & "$] group by 品名 pivot 日期 "
    If rs.State <> 0 Then rs.Close
    rs.Open sql, conn, 3, 3
    Sheets(3).Cells.Delete
    Sheets(3).Range("A2").CopyFromRecordset rs
    For i = 1 To rs.Fields.Count
        Sheets(3).Cells(1, i) = rs.Fields(i - 1).Name
    Next
    '销售统计
    sql = "transform sum(销售收入) "
    sql = sql & " select 品名 from [" & Sheets(2).Name & "$] group by 品名 pivot 日期 "
    If rs.State <> 0 Then rs.Close
    rs.Open sql, conn, 3, 3
    Sheets(4).Cells.Delete
    Sheets(4).Range("A2").CopyFromRecordset rs
    For i = 1 To rs.Fields.Count
        Sheets(4).Cells(1, i) = rs.Fields(i - 1).Name
    Next
    '合并
    sqla = ""
    For i = 2 To 20
        If Sheets(3).Cells(1, i) <> "" Then
            r1 = CStr(Sheets(3).Cells(1, i))
            r2 = CStr(Sheets(4).Cells(1, i))
            r3 = Right(r1, 4) & "销量"
            r4 = Right(r2, 4) & "售额"
            sqla = sqla & "a.[" & r1 & "] as " & r3 & " ,b.[" & r2 & "] as " & r4 & ","
        End If
    Next
    sqla = Left(sqla, Len(sqla) - 1)
    sql = "select a.品名,规格型号,系列," & sqla & " from ([" & Sheets(3).Name & "$] as a left join ["
    sql = sql & Sheets(4).Name & "$] as b on a.品名=b.品名) left join [" & Sheets(2).Name & "$] as c on a.品名=c.品名 where a.品名<>''"
    If rs.State <> 0 Then rs.Close
    rs.Open sql, conn, 3, 3
    Sheets(1).Range("6:100000").ClearContents
    Sheets(1).Range("C7").CopyFromRecordset rs
    For i = 1 To rs.Fields.Count
        Sheets(1).Cells(6, i + 2) = rs.Fields(i - 1).Name
    Next
    Sheets(2).Cells.Delete
    Sheets(3).Cells.Delete
    Sheets(4).Cells.Delete
    Application.ScreenUpdating = True
End Sub