从一个工作簿中提取数据并在另一个中粘贴注释

我想将数据从一个工作簿复制到另一个工作簿。

我的源工作簿在每行中列出了一些意见。 当我使用我的代码复制时，它不相应地复制评论。 任何人都可以帮忙，我怎么可以从一个工作簿复制到另一个与评论领域？ 我的意见在P栏

Sub Extract() 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 DestinationWB = ThisWorkbook path1 = DestinationWB.Path FileWithPath = path1 & "\Downloads\CTT.xlsx" Set OriginWB = Workbooks.Open(filename:=FileWithPath) lastRow = OriginWB.Worksheets("Report").Cells(Rows.count, 1).End(xlUp).Row LastCol = OriginWB.Worksheets("Report").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("Report").Cells(22, i).Value With DestinationWB.Worksheets("CTT").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("Report").Range(Cells(23, i), Cells(lastRow, i)).Copy Destination:=DestinationWB.Worksheets("CTT").Cells(5, cell.Column) Else 'handle the error End If Next i OriginWB.Close SaveChanges:=False End Sub 

Answer 1

我重构了您的代码，纠正了不合格的引用，并将“源”和“目标”范围地址打印到“立即”窗口。 这应该让你知道发生了什么。

---

 Sub Extract() Dim DestinationWB As Workbook Dim OriginWB As Workbook Dim FileWithPath As String, path1 As String, TheHeader As String Dim lastRow As Long, col As Long Dim cell As Range, Source As Range Set DestinationWB = ThisWorkbook path1 = DestinationWB.Path FileWithPath = path1 & "\Downloads\CTT.xlsx" Set OriginWB = Workbooks.Open(Filename:=FileWithPath) With OriginWB.Worksheets("Report") lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row For col = 1 To .Cells(22, .Columns.Count).End(xlToLeft).Column 'get the name of the field (names are in row 22) TheHeader = OriginWB.Worksheets("Report").Cells(22, col).Value With DestinationWB.Worksheets("CTT").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 Set Source = .Range(.Cells(23, col), .Cells(lastRow, col)) Source.Copy Destination:=cell.Offset(1) Debug.Print Source.Address(External:=True), "Copied to ", cell.Offset(1).Address(External:=True) Else 'handle the error End If Next End With OriginWB.Close SaveChanges:=False End Sub