如何可以实现批量导入数据？

stvent

请问如何可以实现把一个文件夹内的多份表格，按特点的单元格内容填充到汇总表上？如下图，汇总表及子表打开如下，我希望可以实现，在主表上执行一个宏或VBA就可以把各子表对应的列内容自动填充到汇总表上！谢谢帮忙！

stvent

上图我只是手填了一个，实际想要实现的各子表对应列的内容自动填充到汇总表

userlfj

不打开取值，高手继续。。。

stvent

请帮忙！！！！！

约定的童话

Sub 汇总()
    Application.ScreenUpdating = False
    Dim MyPath, MyName, AWbName, Wb As Workbook, n, j, arr, brr(1 To 10000, 1 To 8)
    [A2:H10000] = ""
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.csv")
    AWbName = ActiveWorkbook.Name
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            With Workbooks(1)
                arr = ActiveSheet.[a1].CurrentRegion
                For i = 2 To UBound(arr)
                    For j = 2 To 11
                        n = n + 1
                        brr(n, 1) = Split(MyName, "-")(0)
                        brr(n, 2) = Split(MyName, "-")(1)
                        brr(n, 3) = Split(MyName, "-")(2)
                        brr(n, 4) = Split(MyName, "-")(3)
                        brr(n, 5) = Split(Split(MyName, "-")(4), ".")(0)
                        brr(n, 6) = arr(i, 1)
                        brr(n, 7) = arr(1, j)
                        brr(n, 8) = arr(i, j)
                    Next
                Next
                n = Workbooks("汇总.xlsm").Sheets("汇总").[a65536].End(3).Row + 1
                Workbooks("汇总.xlsm").Sheets("汇总").Range("a" & n).Resize(UBound(brr), 8) = brr
                 n = 0: Erase brr
                Wb.Close False
            End With
        End If
        MyName = Dir
    Loop
    MsgBox "汇总完毕！", , "报告！"
    Application.ScreenUpdating = True
End Sub
给你一段代码自己改下吧....

Jaofuan

1. Sub jaofuan()
   
2.     Dim wb As Workbook, ar, br(1 To 10000, 1 To 7), mFull$, row$
   
3.     Dim mPath$: mPath = "C:\Users\Administrator\Desktop\2019-11-5"  ' **** 路径，请自行更改！
   
4.     Dim mName$: mName = Dir(mPath & "*.xlsx")
   
5.     Application.ScreenUpdating = False
   
6.     Do While mName <> ""
   
7.         mFull = mPath & mName
   
8.         Set wb = CreateObject(mFull)
   
9.         row = wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).row
   
10.         ar = wb.Sheets(1).Range("a1:g" & row)
    
11.         For i = 4 To UBound(ar)
    
12.             p = p + 1
    
13.             br(p, 1) = ar(2, 7)
    
14.             br(p, 2) = ar(2, 5)
    
15.             br(p, 3) = ar(i, 2)
    
16.             br(p, 5) = ar(i, 3)
    
17.             br(p, 6) = ar(i, 4)
    
18.             br(p, 7) = ar(i, 5)
    
19.         Next
    
20.         wb.Close False    ' 不保存关闭
    
21.         mName = Dir
    
22.     Loop
    
23.     Set wb = Nothing
    
24.     [b2].Resize(10000, 7) = br
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "操作已完成 ", 64, "提醒"
    
27. End Sub

复制代码

stvent

约定的童话 发表于 2019-11-6 16:11
Sub 汇总()
    Application.ScreenUpdating = False
    Dim MyPath, MyName, AWbName, Wb As Workbook, ...

为什么取不到文件夹下的文件的？
因为我的是*.xlsx

约定的童话

MyName = Dir(MyPath & "\" & "*.xlsx")

stvent

约定的童话 发表于 2019-11-6 16:24
MyName = Dir(MyPath & "\" & "*.xlsx")

怎么我就取不到呢，

约定的童话

stvent 发表于 2019-11-6 16:30
怎么我就取不到呢，

你不会代码没有改直接用吧？代码要根据你的实际文件格式内容修改才可以啊