[發問] 資料複製貼上問題。

本帖最後由 stephenlee 於 2020-7-18 12:55 編輯

我有 2個工作表,一個是資料來源, 另一個是要從資料來源中,
將資料複製過去的工作表。

例如在100欄中複製約10欄, 而每一次我都是自己每一行從第二列複製至尾,再每一行貼上至目標工作表,這樣下來會很花時間。

同時因為資料來源的欄位排列未必是每次一樣, 今天在 A欄的資料,明天可能在C欄, 但是欄位的名稱是固定不變的。

我想用VBA 先尋找資料來源的固定欄位名稱, 再由該欄位的第二列打直複製至目標工作表的固定欄位的第二至尾列。

例如工作表1,有很多資料, 但我只需 4個欄位名稱的資料, 將資料複製至工作表2 內。

意思是找尋資料來源的欄位, 再配目標貼上工作表上的欄位。

因為還有其他工作表是超於100欄的, 同時要抽取的資料,也很多, 如何用VBA 做以上動作,謝謝。

資料來源的活頁簿名稱不是固定的, 而活頁簿的工作表名為 Raw Data 是固定的

貼到另外一個活頁簿名為Data.xlsm內的名稱工作表1 內

question 2.zip (9.23 KB)

樓主熱帖

cody

中學生 Rank: 2

帖子: 16
主題: 2
精華: 0
積分: 55
點名: 0
作業系統: macOS / Windows
軟體版本: Office 2010/2019
閱讀權限: 20
性別: 男
註冊時間: 2020-7-9
最後登錄: 2021-8-7

4^#

發表於 2020-9-16 12:36 | 只看該作者

If xB.Name <> ThisWorkbook.Name Then GoTo 101
我將=, 轉換成 <> 但都是不能成功。
...
stephenlee 發表於 2020-9-15 10:54

If Not xB.Name = ThisWorkbook.Name Then GoTo 101

TOP

stephenlee

中學生 Rank: 2

帖子: 63
主題: 32
精華: 0
積分: 125
點名: 0
作業系統: WIn10
軟體版本: OFFICE2013
閱讀權限: 20
註冊時間: 2018-7-19
最後登錄: 2022-8-11

3^#

發表於 2020-9-15 10:54 | 只看該作者

資料來源檔檔名不固定, 須手動開啟再執行程式:
Sub 複製()
Dim xB As Workbook, xU As Range, R&
Dim Sh ...
准提部林發表於 2020-7-19 11:29

  准大,謝謝幫忙。

我想請問一下如果是在其他Workbooks內的Worksheet("Raw Data")內複製資料至
另外一個Workbook內的Worksheet("工作表1")內。

  If xB.Name = ThisWorkbook.Name Then GoTo 101

  If xB.Name <> ThisWorkbook.Name Then GoTo 101

我將=, 轉換成 <> 但都是不能成功。

我要分開Raw Data 頁是在另一個Workbook內複製資料去另外一個WOrkbook內的"工作表1"內。

"Raw Data" Worksheet是固定名稱,而Workbooks名稱則是不固定。
而"工作表1"是固定名稱,同時Workbooks名稱也是固定叫"Data.slxm"謝謝

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-21

2^#

發表於 2020-7-19 11:29 | 只看該作者

資料來源檔檔名不固定, 須手動開啟再執行程式:
Sub 複製()
Dim xB As Workbook, xU As Range, R&
Dim Sht As Worksheet, A, C%, xF As Range
Set Sht = Sheets("工作表1")
Sht.UsedRange.Offset(1, 0).EntireRow.Delete
'-------------------------------------
For Each xB In Workbooks
On Error Resume Next
If xB.Name = ThisWorkbook.Name Then GoTo 101
Set xU = xB.Sheets("Raw Data").UsedRange
R = xU.Rows.Count - 1
If Not xU Is Nothing Then Exit For
101: Next
On Error GoTo 0
If xU Is Nothing Then MsgBox "來源檔案未開啟! ": Exit Sub
If R = 0 Then MsgBox "來源檔案無資料! ": Exit Sub
'欄位::數量-號碼-名稱-日期
For Each A In Array("Total Qty", "no", "name", "date2")
C = C + 1
Set xF = xU.Rows(1).Find(A, Lookat:=xlWhole)
If Not xF Is Nothing Then xF(2).Resize(R).Copy Sht.Cells(2, C)
Next
End Sub

XX001.rar (20.42 KB)

================================

TOP