从一个工作簿中提取数据，具体取决于列名称并将其粘贴到另一个工作簿中

我有两个工作簿。 Book1和Book2。

我想将Book1，Sheet1的内容复制到Book2 Sheet3。

book1的sheet1中的数据从第22行开始，我希望它们从第5行粘贴到sheet3的book2。

在less数情况下，我想跳过列并粘贴选定的列。

例如：从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