多個不同檔案工作表複製集中貼到1個檔案裡的工作表

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

1^# 跳轉到 »

發表於 2021-10-18 10:28 | 顯示全部帖子

本帖最後由 samwang 於 2021-10-18 10:34 編輯

回復 1# oak0723-1

有3個問題，請確認實際需求為何或者可參考後學建議，謝謝
1. Excel B欄的檔名和實際檔名不一樣(有空白)時要如何處置?
2. Excel C欄的工作表名稱有寫錯時要如何處置?
3. Excel D、E欄起始/終止，要以輸入為主嗎?

建議:
1. 程式直接開啟抓取那個資料夾的檔案
2. 將所有檔名貼至sheet(集中 (目錄)) 的B欄
3. 將檔案的sheet 1資料貼至sheet(集中)，從A欄開始貼入資料依序往右貼到檔案結束

1.PNG (46.04 KB)

TOP

samwang

大學生 Rank: 4

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

2^#

發表於 2021-10-18 12:14 | 顯示全部帖子

回復 1# oak0723-1

B、C欄如輸入錯誤則F欄會顯示錯誤(排除B欄空格問題)，請測試看看，謝謝

Sub test()
Dim Arr, Ar(), xD, a, n%, T, sh$, wb As Workbook, ws As Worksheet
Tm = Timer
Application.ScreenUpdating = False
a = ThisWorkbook.Path
Arr = Sheets(1).Range([b1], [c65536].End(3))
fileOrg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
Set fs = CreateObject("Scripting.FileSystemObject")
a = ThisWorkbook.Path
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
T = Replace(Split(f1.Name, ".")(0), " ", "")
xD(T) = f1.Path
Next
C = 1
For i = 3 To UBound(Arr)
T = Replace(Arr(i, 1), " ", "")
If xD.Exists(T) Then
      Set wb = Workbooks.Open(xD(T))
      sh = Arr(i, 2)
      On Error Resume Next
      Set ws = Worksheets(sh)
      If Err <> 0 Then
         wb.Close
         Sheets(1).Cells(i, 6) = "工作表名稱有錯誤"
         Err.Clear: GoTo 99
      End If
      With Sheets(sh)
         If .FilterMode Then .ShowAllData
         Drr = .Range(.[m1], .[a65536].End(3))
         s = s + 1
      End With
      wb.Close
      Sheets("集中").Cells(1, C).Resize(UBound(Drr), 13) = Drr
      C = C + 13
Else
      Sheets(1).Cells(i, 6) = "檔名有錯誤"
End If
99: Next
Application.ScreenUpdating = True
Set wb = Nothing: Set ws = Nothing
MsgBox Timer - Tm
End Sub

TOP

samwang

大學生 Rank: 4

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

3^#

發表於 2021-10-20 07:38 | 顯示全部帖子

回復 5# oak0723-1

幫我加一個排序功能，也就是依每個檔案資料的第一欄為準由上至下由小至大
>> 修改如下紅字部分，謝謝

Sub test()
Dim Arr, Brr, Drr, Ar(), xD, a, n%, T, sh$, wb As Workbook, ws As Worksheet
Tm = Timer
Application.ScreenUpdating = False: Application.DisplayAlerts = False
...
...
...
With Sheets(sh)
         If .FilterMode Then .ShowAllData
         R = .[a65536].End(3).row
         With Range("a7:m" & R)
            Brr = .Value
            .Sort key1:=.Item(1), Order1:=1, Header:=2
         End With
         Drr = .Range("a1:m" & R)
         .Range("a7:m" & R) = Brr
      End With
      wb.Close
      Sheets("集中").Cells(1, C).Resize(UBound(Drr), 13) = Drr
      C = C + 13
...
...
..
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Set wb = Nothing: Set ws = Nothing
MsgBox Timer - Tm
End Sub

TOP

samwang