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

oak0723-1

各位先進好
因為使用在2016或2018版本的EXCEL
特別容易當機或檔案損毀
所以希望用VBA除了方便外也希望不會常常造成檔案當機或檔案損毀
如附件
在同1個檔案夾裡
在檔名為"集中"的工作表"集中(目錄)"
依序輸入指定"檔名"和指定"工作表名稱"希望將該工作表的"A~M"複製到檔名為"集中"的工作表"集中"的"A~M"欄位
例如
(1)順序1指定"0(1)"的"1216"工作表的"A~M"欄位裡的資料複製貼到檔名為"集中"的工作表"集中"的"A~M"欄位
(2)順序2指定"0(2)"的"1216"工作表的"A~M"欄位裡的資料複製貼到檔名為"集中"的工作表"集中"的"N~Z"欄位
(3)順序3指定"0(3)"的"1216"工作表的"A~M"欄位裡的資料複製貼到檔名為"集中"的工作表"集中"的"AA~AM"欄位
(4)順序4指定"0(4)"的"1216"工作表的"A~M"欄位裡的資料複製貼到檔名為"集中"的工作表"集中"的"AN~AZ"欄位
(5)順序5指定"0(4)"的"1216"工作表的"A~M"欄位裡的資料複製貼到檔名為"集中"的工作表"集中"的"BA~BM"欄位

samwang

回復 1# oak0723-1

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

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

samwang

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

oak0723-1

回復 3# samwang


    謝謝你
我再測試檢視一下

oak0723-1

回復 3# samwang


    你好
不好意思我漏了
可否
幫我加一個排序功能
也就是依每個檔案資料的第一欄為準由上至下由小至大
若資料上到下已是從小排到大則不需再排

samwang

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

oak0723-1

回復 6# samwang


    你好
測試結果
沒有改變
並沒有以第一欄位為準由上至下由小至大排序喔
謝謝~

samwang

回復 7# oak0723-1

並沒有以第一欄位為準由上至下由小至大排序喔
>> 有小小排到大如附件，我猜可能數值看不出來，已經轉為時間格式，請再測試看看，謝謝

samwang

回復 7# oak0723-1

對不起，忘了附檔，已補上，請再測試看看，謝謝

oak0723-1

回復 9# samwang


   謝謝你
完成了
感恩~~~