Iterate through a column and if there is a match in the header of another sheet, then copy and transpose data into original sheet

Question

I'm trying to do something which appears to be simple but proving a little too difficult for me.

I have two sheets; master and data.

master has a set of field names in column A
data has the field name across the top header (row 1)

What I want to do is:

iterate through column A of master and for each field, check if the field exists in row 1 of data
if it does, copy all the data from that column in data where the match exists (excluding the header) and paste transpose the data into the corresponding row in master.

To make is easier to visualize, master looks like this:

 id   | 
 total|

...and data looks like this:

id | name | total
-------------------------
 1 | Khar        | 5
 2 | SantaCruz   | 3
 3 | Sion        | 2
 4 | VT          | 1
 5 | newFort     | 3

The end result in master would look like this:

 id   | 1 | 2 | 3 | 4 | 5
 total| 5 | 3 | 2 | 1 | 3

These are simplistic examples. The actual sheets have hundreds of rows and columns and they can change so hard coding field names into any solution is not really an option.

The code I have so far is shown below.

    Sub CopyTranspose()

      Dim x As Integer
      Dim whatToFind As String
      Dim NumRows As Range
      Dim rngFound As Range
      Dim rgCopy As Range
      Dim LastRow As Long
      Dim LastRowMaster As Long
      Dim LastCol As Integer

      Sheets("master").Select

      ' Select cell BR13, *first line of data*.
      Range("A1").Select
      ' Set Do loop to stop when an empty cell is reached.
      Do Until IsEmpty(ActiveCell)

        whatToFind = ActiveCell.Value

    'Find name and copy
    Sheets("data").Select
    With ActiveSheet
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    With Sheets("data").Range("A1:ZZZ" & LastRow)
        Set rngFound = Cells.Find(What:=whatToFind, After:=Range("A1"), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False)

        If Not rngFound Is Nothing Then
            rngFound.Select
            ActiveCell.Offset(1, 0).Copy


       End If
       End With


         'find name then offset and paste
         Sheets("master").Select
         With ActiveSheet
         LastRowMaster = .Cells(.Rows.Count, "A").End(xlUp).Row
         End With

     With Sheets("master").Range("A1:A" & LastRowMaster)
        Set rngFound = Cells.Find(What:=whatToFind, After:=Range("A1"), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False)

        If Not rngFound Is Nothing Then
            rngFound.Select
            ActiveCell.Offset(0, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=True
            ActiveCell.Offset(1, -2).Select
         End If


     End With

         ' Step down 1 row from present location.
         ActiveCell.Offset(1, 0).Select
      Loop
   End Sub

The error I'm getting is

'1004': Application-defined or object-defined error

on line With Sheets("data").Range("A1:ZZZ" & LastRow)

I've tried to butcher something together from the questions already answered here so I don't even know if the above is the best option to use for this particular task.

Any help would really be appreciated. Many thanks

Edit 1: Thanks to @CATSandCATSandCATS I was able to resolve the above issue by reducing the range. i.e. With Sheets("data").Range("A1:SA" & LastRow)

However, I'm getting another error now - "'1004': PasteSpecial method of Range class failed" on line Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Pᴇʜ · Accepted Answer

I suggest the following:

Read headers of master and data sheets into arrays for faster matching!

Loop through master "header" column A
Match each header with the data headers (row 1)
If they match transpos data

So outging from this data …

you will end up with the following master …

Option Explicit

Public Sub CopyTranspose()
    Dim wsMaster As Worksheet 'define master sheet
    Set wsMaster = ThisWorkbook.Worksheets("master")

    Dim wsData As Worksheet 'define data sheet
    Set wsData = ThisWorkbook.Worksheets("data")

    'read master headers (column A) into array
    Dim MasterHeaders() As Variant
    MasterHeaders = wsMaster.Range("A1", wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)).Value

    'read data headers (row 1) into array
    Dim DataHeaders() As Variant
    DataHeaders = wsData.Range("A1", wsData.Cells(1, wsData.Columns.Count).End(xlToLeft)).Value

    Dim MatchedColumn As Long
    Dim MatchedColumnData As Range

    Dim iRow As Long
    For iRow = LBound(MasterHeaders, 1) To UBound(MasterHeaders, 1)
        MatchedColumn = 0 'initialize
        On Error Resume Next 'next line throws error if headers do not match (hide it)
        MatchedColumn = Application.WorksheetFunction.Match(MasterHeaders(iRow, 1), DataHeaders, 0)
        On Error GoTo 0 'always re-enable error reporting!!!

        If MatchedColumn > 0 Then 'a matching header was found
            'find last used row in matched column to get all data
            Set MatchedColumnData = wsData.Range(wsData.Cells(2, MatchedColumn), wsData.Cells(wsData.Rows.Count, MatchedColumn).End(xlUp))
            'transpos data to master sheet
            wsMaster.Cells(iRow, 2).Resize(columnsize:=MatchedColumnData.Rows.Count).Value = Application.WorksheetFunction.Transpose(MatchedColumnData)
        End If
    Next iRow
End Sub

Note that there is a limitation: If there are more rows in the data sheet than columns are available in the master sheet then you cannot transpose the data because it doesn't fit into one row (Excel has more rows than columns).

Iterate through a column and if there is a match in the header of another sheet, then copy and transpose data into original sheet

Answers (2)

Related Questions