汇总本文件夹里所有表格的相应内容到某个文档

njcj2008

每个月的定货信息汇总到一张表里
每次订货为一个EXCEL表格，
到月底手动统计生成一个汇总表格，
用VBA把本文件夹里的所有表格里的相应内容复制出来生成到一个新的表格。
哪们大神帮帮忙，十分感谢 。
测试.rar (19.88 KB, 下载次数: 18)

2017-12-15 19:20 上传

点击文件名下载附件
订货信息汇总

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
遍历文件的资料供参考

njcj2008

liulang0808 发表于 2017-12-15 19:35
http://club.excelhome.net/thread-1258425-1-1.html
遍历文件的资料供参考

不知道是否有人愿意帮忙，可出RMB

lsc900707

njcj2008 发表于 2017-12-15 19:50
不知道是否有人愿意帮忙，可出RMB

问题很简单，但需要花时间。

njcj2008

lsc900707 发表于 2017-12-15 19:55
问题很简单，但需要花时间。

是的，就是时间问题。

lsc900707

njcj2008 发表于 2017-12-15 20:13
是的，就是时间问题。

各个订单里总额不可以在D6单元格里直接求和出来吗？

cqcbc

如果订单格式固定，可试一下

Sub cqcbc()
    Application.ScreenUpdating = False
     Set fso = CreateObject("scripting.filesystemobject")
     Set ff = fso.getfolder(ThisWorkbook.Path & "\")
     ActiveSheet.UsedRange.Offset(2).ClearContents
     Set sh = ActiveSheet
     a = 3
     For Each f In ff.Files
         Set wb = Workbooks.Open(f)
         arr = wb.Sheets("Sheet1").UsedRange
         wb.Close False
         Cells(a, 1) = arr(11, 2)
         Cells(a, 2) = arr(11, 2)
         Cells(a, 3) = arr(10, 2)
         Cells(a, 4) = arr(10, 5)
         Cells(a, 5) = arr(3, 4)
         Cells(a, 6) = arr(4, 4)
         Cells(a, 7) = arr(5, 4)
         Cells(a, 8) = arr(3, 5) + arr(4, 5) + arr(5, 5)
         a = a + 1
                Next f
     Application.ScreenUpdating = True
End Sub

LMY123

数组法多薄单表不连续单元格合并

lsc900707

njcj2008 发表于 2017-12-15 20:13
是的，就是时间问题。

Sub gj23w982()
    Dim arA(1 To 10000, 1 To 9)
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls*")
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set sht = GetObject(p & f).Sheets("Sheet1")
            With sht
                 s = .[b11] & "|" & .[b10] & "|" & .[e10] & "|" & .[d3] & "|" & .[d4] & "|" & .[d5] & "|" & .[e3] + .[e4] + .[e5] & "|" & .[b8]
                 m = m + 1
                 arA(m, 1) = m
                 For j = 2 To 9
                     arA(m, j) = Split(s, "|")(j - 2)
                 Next
             End With
            Workbooks(f).Close False
        End If
        f = Dir
    Loop
    Set sht = Nothing
    With Sheet1
        .[a1].CurrentRegion.Offset(2).ClearContents
        .[a3].Resize(m, 9) = arA
    End With
    Application.ScreenUpdating = True
    MsgBox "合并完成！"
End Sub

wxxydl

这种方式汇总  见附件
Sub huiz()
    Dim d As Object, dian_name As String, wb As Workbook
    Dim f, arr, brr, ws As Worksheet
    Dim fd As FileDialog
    Dim crr(1 To 100, 1 To 11)
    On Error Resume Next
    Set d = CreateObject("scripting.dictionary")
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    dd = Array("序号", "订货日期", "门店名称", "公司", "水龙头", "M5水管", "X8锁", "总额", "收件地址", "发票号码", "备注")
    For i = 1 To UBound(crr, 2)
        crr(1, i) = dd(i - 1)
    Next
    k = 2
    With fd
      .AllowMultiSelect = True
      .Filters.Add "excel文件", "*.xls*"
      .Title = "请选择要汇总的文件"
      If .Show = -1 Then
         For Each f In .SelectedItems
           crr(k, 1) = k - 1
          Set wb = Application.Workbooks(Mid(f, InStrRev(f, "\") + 1, 255))
          If Err.Number > 0 Then
             Err.Clear
             Set wb = Application.Workbooks.Open(f)
          End If
          Set ws = wb.Worksheets("sheet1")
          With ws
            arr = .[a1].CurrentRegion
            dian_name = .Cells(UBound(arr) + 4, 2)
            sj = .Cells(UBound(arr) + 5, 2)
            gs = .Cells(UBound(arr) + 4, 5)
            dz = .Cells(UBound(arr) + 2, 2)
          End With
          wb.Close
            For i = 3 To UBound(arr)
                If arr(i, 2) <> "" Then
                    d((dian_name) & (arr(i, 2))) = arr(i, 4)
                crr(k, i + 2) = d((dian_name) & (crr(1, i + 2)))
                crr(k, 8) = crr(k, 8) + arr(i, 5)
                End If
            Next
            crr(k, 2) = sj
            crr(k, 3) = dian_name
            crr(k, 4) = gs
            crr(k, 9) = dz

          k = k + 1
         Next
       End If
      End With

   ActiveWorkbook.Worksheets("sheet1").[a2].Resize(100, 11) = crr
End Sub