Sub PKL_對應欄位貼資料()
'Sheets("PKL")保留列20的標題,去抓取廠商PK的對應欄位,並貼上資料
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 = "代入檔案名稱"
On Error Resume Next: Set xB = Workbooks(FN): On Error GoTo 0 '檢查PK檔是否已開啟
If xB Is Nothing Then Set xB = Workbooks.Open(MyBook.Path & "\" & FN) '若PK檔未開啟, 開啟之
Set xArea = xB.Sheets(1).UsedRange '設定PK檔資料範圍為range物件
'這裡需改成表頭下一列~A欄的第一個空白的上一列(即copy有資料的部份就好,不要包含空白列)
'------------------------------------
Set MySht = MyBook.Sheets("PKL") '本檔資料工作表
MySht.UsedRange.Offset(1, 0).ClearContents '裡需改成清除 標題行下一列~SUB TOTAL上一列
'以下需改成從表頭下一列開始貼,但因為有多份資料,每次貼時,都要從A欄找到的第一個空白處開始貼
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
[attach]36207[/attach]作者: Andy2483 時間: 2023-4-26 11:43
Option Explicit
Sub TEST()
Dim Brr, R&, j&, C%
C = Cells(19, Columns.Count).End(xlToLeft).Column
R = Range([A1], ActiveSheet.UsedRange).Rows.Count
i01:
Brr = Range([A19], Cells(20, C))
For j = 1 To UBound(Brr, 2)
If Trim(UCase(Brr(1, j))) <> Trim(UCase(Brr(2, j))) Then
Cells(20, j).Resize(R - 19).Insert Shift:=xlToRight
Cells(20, j) = Cells(19, j): GoTo i01
End If
Next
Erase Brr
End Sub
這應該有更適合的寫法,請各位前輩指教作者: PJChen 時間: 2023-4-26 23:10
