帖子: 222
主題: 56
精華: 0
積分: 285
點名: 0
作業系統: window
軟體版本: office2003
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2010-8-30
最後登錄: 2024-4-22

論壇贊助勳章論壇榮譽勳章

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2022-5-8 23:59 | 只看該作者

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

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

圖1.jpg (60.67 KB)

圖2.jpg (81.88 KB)

圖3.jpg (347.13 KB)

20個檔案集中至1個檔.rar (831.29 KB)

樓主熱帖

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

2^#

發表於 2022-5-9 09:55 | 只看該作者

回復 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

TOP

oak0723-1

中學生 Rank: 2

帖子: 222
主題: 56
精華: 0
積分: 285
點名: 0
作業系統: window
軟體版本: office2003
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2010-8-30
最後登錄: 2024-4-22

論壇贊助勳章論壇榮譽勳章

3^#

發表於 2022-5-9 21:09 | 只看該作者

感恩.感恩
謝謝

TOP

oak0723-1

中學生 Rank: 2

帖子: 222
主題: 56
精華: 0
積分: 285
點名: 0
作業系統: window
軟體版本: office2003
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2010-8-30
最後登錄: 2024-4-22

論壇贊助勳章論壇榮譽勳章

4^#

發表於 2023-10-15 21:19 | 只看該作者

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

Image 013.jpg (76.94 KB)

(1121015)20個檔案集中至1個檔.rar (835.41 KB)

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

5^#

發表於 2023-10-16 10:07 | 只看該作者

回復 4# oak0723-1

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

執行結果:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

singo1232001

　暱稱: 熱狗慶

中學生 Rank: 2

帖子: 353
主題: 5
精華: 0
積分: 386
點名: 0
作業系統: windows7
軟體版本: vba,vb,excel2007
閱讀權限: 20
性別: 男
註冊時間: 2017-1-8
最後登錄: 2024-4-26

論壇榮譽勳章論壇贊助勳章

6^#

發表於 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

TOP

Andy2483