Sub MO()
Dim C&, R&, xD, xB As Workbook, Arr, Brr, U&, N&
Set xD = CreateObject("Scripting.Dictionary")
With Sheets("Dump")
.UsedRange.Offset(1, 0).EntireRow.Delete
For C = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
xD(.Cells(1, C) & "") = C: N = N + 1
Next
End With
On Error Resume Next
Set xB = Workbooks("vsDataAnrFunction.csv")
On Error GoTo 0
If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "\vsDataAnrFunction.csv")
Arr = xB.Sheets(1).UsedRange
ReDim Brr(1 To UBound(Arr), 1 To N)
For C = 1 To UBound(Arr, 2)
U = xD(Arr(1, C) & ""): If U = 0 Then GoTo 101
For R = 2 To UBound(Arr)
Brr(R - 1, U) = Arr(R, C)
Next R
101: Next C
xB.Close 0
Sheets("Dump").[A2].Resize(UBound(Arr) - 1, N).Value = Brr
End Sub
另方:
Sub MO_2()
Dim MyBook As Workbook, MySht As Worksheet, xR As Range, xF As Range
Dim FN$, xB As Workbook, xArea As Range
Application.ScreenUpdating = False
Set MyBook = ThisWorkbook '本檔
FN = "vsDataAnrFunction.csv" 'csv檔案名稱
On Error Resume Next: Set xB = Workbooks(FN): On Error GoTo 0 '檢查csv檔是否已開啟
If xB Is Nothing Then Set xB = Workbooks.Open(MyBook.Path & "\" & FN) '若csv檔未開啟, 開啟之
Set xArea = xB.Sheets(1).UsedRange '設定csv檔資料範圍為range物件
'------------------------------------
Set MySht = MyBook.Sheets("Dump") '本檔資料工作表
MySht.UsedRange.Offset(1, 0).EntireRow.Delete '清除原有資料(保留標題行)
For Each xR In Range(MySht.[A1], MySht.Cells(1, Columns.Count).End(xlToLeft))
Set xF = xArea.Rows(1).Find(xR, Lookat:=xlWhole) '逐一尋找csv第一行符合標題文字的位置
If xF Is Nothing Then GoTo 101 '找不到符合時, 略過
xR.Resize(xArea.Rows.Count).Value = xF.Resize(xArea.Rows.Count).Value '複製整欄資料
101: Next
xB.Close 0
End Sub
