1つのブックからデータを抽出し、コメントを付けて別のブックに貼り付ける

Question

あるブックから別のブックにデータをコピーしたいと思います。

ソースブックには、各行にいくつかのコメントが記載されています。コピーするために自分のコードを使用すると、それに応じてコメントがコピーされません。いずれかの助け、どのようにコメント欄で1つのブックから別のブックにコピーすることができますか？私のコメントは、私はあなたのコードは未修飾の参照を修正し、イミディエイトウィンドウに送信元と送信先の範囲のアドレスを印刷リファクタリング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