麻辣家族討論版版 » Excel程式區 » 將多個檔案同一個欄位資料複製集中到1個檔案

oak0723-1 發表於 2022-5-8 23:59

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

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

samwang 發表於 2022-5-9 09:55

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118783&ptid=23655]1#[/url] [i]oak0723-1[/i] [/b]

請測試看看，謝謝

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 發表於 2022-5-9 21:09

感恩.感恩
謝謝

oak0723-1 發表於 2023-10-15 21:19

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

Andy2483 發表於 2023-10-16 10:07

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121927&ptid=23655]4#[/url] [i]oak0723-1[/i] [/b]


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

執行結果:
[attach]36889[/attach]



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 發表於 2023-10-16 13:56

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 發表於 2023-10-16 14:32

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121930&ptid=23655]6#[/url] [i]singo1232001[/i] [/b]


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

oak0723-1 發表於 2023-10-16 22:29

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121930&ptid=23655]6#[/url] [i]singo1232001[/i] [/b]


   非常感謝~~

oak0723-1 發表於 2023-10-16 22:30

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121929&ptid=23655]5#[/url] [i]Andy2483[/i] [/b]


    感恩感恩
非常感恩~~

singo1232001 發表於 2023-10-17 18:32

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121931&ptid=23655]7#[/url] [i]Andy2483[/i] [/b]


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

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

oak0723-1 發表於 2023-10-17 22:34

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121929&ptid=23655]5#[/url] [i]Andy2483[/i] [/b]


    不知為何
執行會卡在檔案002
麻煩解惑

oak0723-1 發表於 2023-10-17 22:54

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121929&ptid=23655]5#[/url] [i]Andy2483[/i] [/b]


    知道為何
執行時會卡住在002檔案
是excel版本因素嗎?還是檔名字型?

Andy2483 發表於 2023-10-18 07:47

[i=s] 本帖最後由 Andy2483 於 2023-10-18 08:04 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121944&ptid=23655]12#[/url] [i]oak0723-1[/i] [/b]

謝謝前輩回復
學習到的解決方案是需將數字轉化為文字,用CStr()函數處理成.Sheets(CStr(Arr(i, 2)))或 .Sheets(Arr(i, 2) & "")
[url]https://learn.microsoft.com/zh-tw/office/vba/language/concepts/getting-started/type-conversion-functions[/url]
後學考慮不周全,謝謝前輩指點
後學另建議以變數宣告為字串盛裝方案如下

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

Andy2483 發表於 2023-10-18 08:18

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121939&ptid=23655]10#[/url] [i]singo1232001[/i] [/b]


    謝謝前輩

oak0723-1 發表於 2023-10-18 21:20

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121945&ptid=23655]13#[/url] [i]Andy2483[/i] [/b]


    千萬別叫我前輩,你真是高手
謝謝你
解決了
感恩

Andy2483 發表於 2023-10-31 16:28

謝謝論壇,謝謝各位前輩
複習的心得註解如下,請各位前輩指教

Option Explicit
Sub TEST()
Dim Arr, i%, K%, xS As Worksheet, xB As Workbook, Ph$, T1$, T2$
[color=SeaGreen]'↑宣告變數:Arr是通用型變數,(i,K)是短整數,(Ph,T1,T2)是字串變數,xS是工作表變數
'xB是活頁簿變數[/color]
Application.ScreenUpdating = False
[color=SeaGreen]'↑令螢幕不隨著程序執行結果做變化[/color]
Set xB = ThisWorkbook: Ph = xB.Path & "\"
[color=SeaGreen]'↑令xB這活頁簿變數是 本檔
'令Ph這字串變數是本檔所在路徑連接"\"所組成的字串[/color]
Arr = Range([順序!E2], [順序!C65536].End(3))
[color=SeaGreen]'↑令Arr這通用型變數是 二維陣列,以"順序"表[E2]到C欄最後有內容儲存格,
'以這範圍儲存格值帶入[/color]
Sheets("集中").Cells.Clear
[color=SeaGreen]'↑令"集中"工作表全部儲存格清除內容[/color]
For i = 1 To UBound(Arr)
[color=SeaGreen]'↑設順迴圈!令i從1到 Arr陣列縱向最大索引列號[/color]
   T1 = Arr(i, 1) & ".xlsx": T2 = Arr(i, 2)
[color=SeaGreen]   '↑令T1這字串變數是 i迴圈列第1欄Arr陣列值連接".xlsx"組成的字串
   '令T2這字串變數是 i迴圈列第2欄Arr陣列值字串[/color]
   On Error Resume Next
[color=SeaGreen]   '↑令程序不偵錯[/color]
   Set xS = Workbooks(T1).Sheets(T2)
[color=SeaGreen]   '↑令xS這工作表變數是 名為(T1變數)活頁簿裡,名為(T2變數)的工作表[/color]
   If Err.Number <> 0 Then
[color=SeaGreen]   '↑如果傳回或設定指定錯誤的數值不是 0?[/color]
   [url]https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/number-property-visual-basic-for-applications[/url]
      Set xS = Workbooks.Open(Ph & T1).Sheets(T2)
[color=SeaGreen]      '↑令XS變數是開啟Ph變數路徑下名為T1變數活頁簿裡,名為T2變數工作表[/color]
      K = 1
[color=SeaGreen]      '↑令K這短整數變數是 1[/color]
   End If
   On Error GoTo 0
[color=SeaGreen]   '↑令程序恢復偵錯[/color]
   If xS Is Nothing Then
[color=SeaGreen]   '↑如果xS變數不是物件?[/color]
      MsgBox T1 & " 活頁簿, " & T2 & " 工作表不存在!結束執行": Exit Sub
[color=SeaGreen]      '↑令跳出提視窗~~~,結束程序執行[/color]
   End If
   xS.[A:I].Copy xB.Sheets("集中").Cells(1, Arr(i, 3))
[color=SeaGreen]   '↑令xS變數的[A:I]儲存格複製到 xB活頁簿(本檔)"集中"工作表的第1列(指定欄)儲存格
   '指定欄:i迴圈列第3欄Arr陣列值[/color]
   If K = 1 Then xS.Parent.Close 0: K = 0
[color=SeaGreen]   '↑如果K變數是1?(代表xS工作表的活頁簿是執行程序中開啟的),
   'True就令其關閉,令K變數歸零[/color]
   Set xS = Nothing
[color=SeaGreen]   '↑令xS變數釋放[/color]
Next
Set xB = Nothing: Erase Arr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub

查看完整版本: 將多個檔案同一個欄位資料複製集中到1個檔案