CODEWITHSUNDEEP
vbaexcel
Mikz
Mikz

Reputation: 591

Extracting data from one workbook and pasting in another with comments

I would like to copy the data from one workbook to another.

My source workbook has some comments listed in each row. When I use my code to copy, it does not copy the comments accordingly. Could any one help, how I could copy from one workbook to another with the comment field ? my comments are in Column 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

Upvotes: 0

Views: 49

Answers (1)

user6432984
user6432984

Reputation:

I refactored your code correcting the unqualified references and printing the Source and Destination range addresses to the Immediate window. This should give you an idea of what is going on.

enter image description here

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

Upvotes: 1

Related Questions