將多個檔案同一個欄位資料複製集中到1個檔案

oak0723-1

想把同一個資料夾裡的20個檔案同樣欄位的資料複製集中到1個檔的同1個工作表裡面
如圖1,同一個檔案夾有檔名危"01.02~19.20"等20個excel檔的A~I等9個欄位裡的資料
複製到檔名為"集中"的工作表"集中"裡(如圖3)
複製的順序與位置則為在複製前先於檔名為"集中"的工作表"順序"裡先填好(如圖2)

samwang

回復 1# oak0723-1

請測試看看，謝謝

Sub 匯整檔案()
Dim Arr, fs, fc, f1, fn$, xC0, xC1, R%
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False
Tm = Timer
Set fs = CreateObject("Scripting.FileSystemObject")
PH = ThisWorkbook.Path
Set f = fs.GetFolder(PH): Set fc = f.Files
For Each f1 In fc
    If InStr(f1.Name, "集中") Then GoTo 99
    If InStr(f1.Name, "~") Then GoTo 99
    With Workbooks.Open(f1.Path)
        fn = Split(f1.Name, ".")(0)
        Arr = Sheets(1).Range("i6").CurrentRegion
        .Close
    End With
    With Sheets(1)
        R = .Range("c65536").End(3).Row + 1
        .Range("c" & R).NumberFormatLocal = "@"
        .Range("c" & R) = fn
        If xC0 = 0 Then
            xC0 = 1: xC1 = UBound(Arr, 2)
        Else
            xC0 = xC1 + 5: xC1 = xC0 + UBound(Arr, 2) - 1
        End If
        .Range("d" & R) = Replace(Cells(1, xC0).Address(0, 0), "1", "")
    End With
    Sheets(2).Cells(6, xC0).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
99: Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub

oak0723-1

感恩.感恩
謝謝

oak0723-1

若輸入格式改成可輸入檔名和工作表
依所輸入的檔名和工作表執行
要怎麼寫這個VBA

Andy2483

回復 4# oak0723-1


    謝謝前輩發表此情境與範例
後學藉此帖練習VBA,學習方案如下,請前輩參考

執行結果:

下載 (104.22 KB)

2023-10-16 10:06

Option Explicit
Sub TEST()
Dim Arr, i%, Ph$, xS As Worksheet, xB As Workbook, K%
Application.ScreenUpdating = False
Set xB = ThisWorkbook: Ph = xB.Path & "\"
Arr = Range([順序!E2], [順序!C65536].End(3))
Sheets("集中").Cells.Clear
For i = 1 To UBound(Arr)
   On Error Resume Next
   Set xS = Workbooks(Arr(i, 1) & ".xlsx").Sheets(Arr(i, 2))
   If Err.Number <> 0 Then
      Set xS = Workbooks.Open(Ph & Arr(i, 1) & ".xlsx").Sheets(Arr(i, 2))
      K = 1
   End If
   On Error GoTo 0
   If xS Is Nothing Then
      MsgBox Arr(i, 1) & " 活頁簿, " & Arr(i, 2) & " 工作表不存在!結束執行"
      Exit Sub
   End If
   xS.[A:I].Copy xB.Sheets("集中").Cells(1, Arr(i, 3))
   If K = 1 Then xS.Parent.Close 0: K = 0
   Set xS = Nothing
Next
Set xB = Nothing: Erase Arr
End Sub

singo1232001

Sub test2()
Set CN = CreateObject("adodb.connection"): V = Application.Version
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;"
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;"
Set s = Sheets("順序"): Set s0 = Sheets("集中"): s0.Cells.ClearContents
AR = Array("select * from [sheet1$A:I]", "select * from [工作表1$A:I]")
For i = 2 To s.Cells(Rows.Count, 2).End(3).Row
If Dir(ThisWorkbook.Path & "\" & s.Cells(i, "C") & ".xlsx") <> "" Then
    CN.Open V & "Data Source=" & ThisWorkbook.Path & "\" & s.Cells(i, "C") & ".xlsx"
    On Error Resume Next
    Set rs = CN.Execute("select * from [" & s.Cells(i, "D") & "$A:I]")
    If CN.Errors.Count <> 0 Then: CN.Errors.Clear: Set rs = CN.Execute(AR(0))
    If CN.Errors.Count <> 0 Then: CN.Errors.Clear: Set rs = CN.Execute(AR(1))
    On Error GoTo 0
    s0.Range(s.Cells(i, "E") & 2).CopyFromRecordset rs
    s0.Columns(s.Cells(i, "E").Value).NumberFormatLocal = "h:mm:ss;@"
    s0.Range(s.Cells(i, "E") & 6).Resize(1, 9) = Split("A,B,C,D,E,F,G,H,I", ",")
    CN.Close
End If
Next
End Sub

Andy2483

回復 6# singo1232001


    謝謝前輩發表這不必開啟excel檔案就可複製資料的方式
請問這些語法如何入門學起?

oak0723-1

回復 6# singo1232001


   非常感謝~~

oak0723-1

回復 5# Andy2483


    感恩感恩
非常感恩~~

singo1232001

回復 7# Andy2483


youtube  SQL SERVER  安裝
youtube  SSMS 安裝
youtube  OR  bilibili 尚硅谷 SQL教程
   
GPT4
ADODB.Connection

另外可擴充學習
chrome 遠端功能
vmware1.6