從一個工作簿中提取數據並在另一個工作簿中粘貼註釋

Question

我想將數據從一個工作簿複製到另一個工作簿。

我的源工作簿在每行中列出了一些註釋。當我使用我的代碼進行復制時，它不會相應地複製評論。任何人都可以提供幫助，我可以如何使用評論字段從一個工作簿複製到另一個工作簿？我的意見是柱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