從一個工作簿中提取數據，根據不同的列名，並在另一個工作簿

Question

粘貼我有兩個工作簿。 Book1和Book2。

我想複製第一冊的內容，對工作表Sheet1工作表Sheet 3 BOOK2。

book1的sheet1中的數據從第22行開始，我希望它們從sheet5的book2的第5行粘貼。

我在少數情況下，我想跳過列並粘貼選定的列。

例如：來自bk1，sht1，我想要將A列粘貼到Bk2的列B中，sht3; Bk1 sht1，列b粘貼在sht3的A列中，Bk1 sht3的列C在bk2 sht3的列I中。喜歡這個。

我試圖用一個代碼，我在哪裏尋找列，而不是名字。

對於例如：而不是拆分（列A），我想分割（「項目名稱」）並將其粘貼在我的工作表B列。

Sub ExtractBU() 
Dim x As Workbook 
Dim y As Workbook 
Dim Val As Variant 
Dim filename As String 
Dim LastCell As Range 
Dim LastRow As Long 

CopyCol = Split("A,B,C,D,E,F,H,I,K,L,M,O,P", ",") 
LR = Cells(Rows.Count, 1).End(xlUp).Row 
LC = Cells(1, Columns.Count).End(xlToLeft).Column 
LCell = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Address 
LCC = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Column 
lcr = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Row 

Set y = ThisWorkbook 
    Dim path1, Path2 
path1 = ThisWorkbook.Path 
Path2 = path1 & "\Downloads" 
Set x = Workbooks.Open(filename:=Path2 & "\Report.xlsx") 

For Count = 0 To UBound(CopyCol) 
    Set temp = Range(CopyCol(Count) & "22:" & CopyCol(Count) & lcr) 
    If Count = 0 Then 
    Set CopyRange = temp 
    Else 
    Set CopyRange = Union(CopyRange, temp) 
    End If 
Next 

CopyRange.Copy 
y.Sheets("BU").Paste y.Sheets("BU").Range("A4") 
Application.CutCopyMode = False 
x.Close 
End Sub 

誰能告訴我我該怎麼做？任何潛在客戶都會有所幫助

Answer 1

請嘗試以下操作。 根據意見編輯。

Sub ExtractBU() 
    Dim DestinationWB As Workbook 
    Dim OriginWB As Workbook 
    Dim path1 As String 
    Dim FileWithPath As String 
    Dim LastRow As Long, i As Long, LastCol As Long 
    Dim TheHeader As String 
    Dim cell As Range 

    Set OriginWB = ThisWorkbook 
    path1 = OriginWB.Path 
    FileWithPath = path1 & "\Downloads\Report.xlsx" 
    Set DestinationWB = Workbooks.Open(filename:=FileWithPath) 


    LastRow = OriginWB.Worksheets("BU").Cells(Rows.Count, 1).End(xlUp).Row 
    LastCol = OriginWB.Worksheets("BU").Cells(22, Columns.Count).End(xlToLeft).Column 

    For i = 1 To LastCol 
     'get the name of the field (names are in row 22) 
     TheHeader = OriginWB.Worksheets("BU").Cells(22, i).Value 

     With DestinationWB.Worksheets("BU").Range("A4:P4") 
      'Find the name of the field (TheHeader) in the destination (in row 4) 
      Set cell = .Find(TheHeader, LookIn:=xlValues) 
     End With 

     If Not cell Is Nothing Then 
      OriginWB.Worksheets("BU").Range(Cells(23, i), Cells(LastRow, i)).Copy Destination:=DestinationWB.Worksheets("BU").Cells(5, cell.Column) 
     Else 
      'handle the error 
     End If 
    Next i 

    'DestinationWB.Close SaveChanges:=True 

End Sub 

Answer 2

這樣做可以滿足您所要求的所有額外代碼，並且可以再次「保持簡單」。

Sub test() 
Dim lRow As Long 

Workbooks.Open Filename:=ThisWorkbook.Path & "\Downloads" & "\Report.xlsx" 

lRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 

    ThisWorkbook.Range("A22:P" & lRow).Copy Destination:=Workbooks("Report.xlsx").Worksheets("Sheet3").Range("A5") 

End Sub