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

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

1 个答案: