将相同格式文件的文件名及固定的几列汇总到同一个表格中

zongkd

把大量相同格式的文件固定的列（列C和列K)及文件名的某几位横向汇总到同一个excel工作表中，


attach]2260549[/attach

LMY123

Sub ADO法_一薄一列转一行_参考()
    Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, t$, m&, arr(), i&
    Application.ScreenUpdating = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("adodb.connection")
    ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count, 0 To 4)
    On Error Resume Next
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xlsx" Then
            m = m + 1
            If m = 1 Then
                cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;imex=1;hdr=no';data source=" & File
            Else
                t = "[Excel 12.0;imex=1;hdr=no;Database=" & File & ";]."
            End If
            SQL = "select f1 from " & t & "[Sheet1$b1:b5]"
            Set rs = cnn.Execute(SQL)
            For i = 0 To 4
                arr(m, i) = rs.Fields(0).Value
                rs.MoveNext
            Next
        End If
    Next
    Cells.ClearContents
    Range("a1").Resize(m, 5) = arr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

zongkd

没明白，怎么定义要处理的文件位置

LMY123

zongkd 发表于 2018-9-26 08:50
没明白，怎么定义要处理的文件位置

Sub 常规法_一薄多列转一行_参考()
    tt = Timer
    [A3:Z65536] = ""
    Application.ScreenUpdating = False
    p = ThisWorkbook.Path & "\数据表和统计模板\"
    f = Dir(p & "*.xls*")
    ReDim brr(1 To 65536, 0 To 50)
    Do While f <> ""
    n = n + 1
    k = 0
        With GetObject(p & f)
        For Each sht In .Sheets
            arr = sht.UsedRange
            For r = 2 To UBound(arr)
                k = k + 1
                brr(n, 0) = Split(Split(f, ".")(0), "_")(1)
                brr(n, k) = arr(r, 3)
                brr(n, UBound(arr) - 1 + k) = arr(r, 11)
            Next r
        Next
        .Close False
        End With
        f = Dir
    Loop
    Application.ScreenUpdating = True
    [A2].Resize(n, 2 * k + 1) = brr
    MsgBox Timer - tt
End Sub