CODEWITHSUNDEEP
vbaexcelcriteriacopy-pasteworksheet
Nicola
Nicola

Reputation: 25

Copying data from one worksheet and paste against relevant rows in another worksheet

I have a workbook with two sheets one named Datadump with headers in row 1 and site and descriptive data in columns A & B and data in column C. I would like to copy this data and paste it in the Worksheet "Factors".

This worksheet has column headers on row 2 and the same descriptive titles in columns A & B. I would like to paste the data from "Datadump" against the same row labels in "Factors" in column E.

However, "Factors" will have some rows which are not in "Datadump" so it needs to paste against relevant rows. I have tried various code which is not working. Below is the most recent but comes up with a Runtime 1004 error on the pastespecial line. If anyone could help that would be great.

Thanks

'VARIABLE NAME                 'DEFINITION
Dim SourceSheet As Worksheet    'The data to be copied is here
Dim TargetSheet As Worksheet    'The data will be copied here
Dim ColHeaders As Range         'Column headers on Target sheet
Dim MyDataHeaders As Range      'Column headers on Source sheet

Dim DataBlock As Range          'A single column of data
Dim c As Range                  'a single cell
Dim Rng As Range                'The data will be copied here (="Place holder" for the first data cell)
Dim i As Integer

Set SourceSheet = Sheets("Datadump")
Set TargetSheet = Sheets("Factors")

With TargetSheet
    Set ColHeaders = .Range("A2:E2")
    Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With

With SourceSheet
    Set MyDataHeaders = .Range("A1:C1")

    For Each c In MyDataHeaders
        If Application.WorksheetFunction.CountIf(ColHeaders, c.value) = 0 Then
            MsgBox "Can't find a matching header name for " & c.value & vbNewLine & "Make sure the column names are the same and try again."
            Exit Sub
        End If
    Next c

    Set DataBlock = .Range(.Cells(2, 3), .Cells(.Rows.Count, 1).End(xlUp))
    Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)

    For Each c In MyDataHeaders
        i = Application.WorksheetFunction.Match(c.value, ColHeaders, 0)
        Set c = DataBlock
        If Not c Is Nothing Then
            .Columns(c.Column).Copy
            c.PasteSpecial xlPasteValues
        End If
    Next
    Application.CutCopyMode = False
End With

End Sub

Upvotes: 2

Views: 137

Answers (1)

Arun Thomas
Arun Thomas

Reputation: 845

The below code will do the job,

For i = 2 To 100 'considering 100 rows in Datadump sheet
    site1 = Sheets("Datadump").Cells(i, 1).Value
    desc1 = Sheets("Datadump").Cells(i, 2).Value
    For j = 3 To 50 'considering 50 rows in Factors sheet
        site2 = Sheets("Factors").Cells(j, 1).Value
        desc2 = Sheets("Factors").Cells(j, 2).Value
        If site1 = site2 And desc1 = desc2 Then
            Sheets("Factors").Cells(j, 5).Value = Sheets("Datadump").Cells(i, 3).Value
        End If
    Next j
Next i

Upvotes: 3

Related Questions