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

Welcome to Stack Overflow. Please note that because this is no free code writing service it is necessary to show either what you have tried so far and where you got stuck or errors (by showing your code) or at least to show what you have researched and the effort you made. If you did nothing at all it is just asking us to do all the work for you. Reading [ask] might help you to improve your question. — Pᴇʜ, Mar 07 '19 at 13:25
Thanks, I've updated the question to include my current effort. — gnosys101, Mar 07 '19 at 14:05
You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). See my answer below for a clean and fast solution. — Pᴇʜ, Mar 07 '19 at 14:51
Without a realistic example of your data and problems, it's hard to advise. But what you show can be done easily with native Excel functions. VBA not required. — Ron Rosenfeld, Mar 07 '19 at 14:57

Pᴇʜ · Accepted Answer · 2019-03-07T14:52:54.897

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).

This works perfectly. It's a much neater solution and I need to train myself to think of these types of solutions rather than how I would do it using manual steps. Thanks and thank you to all who took the time to help solve this problem. — gnosys101, Mar 07 '19 at 16:35

CATSandCATSandCATS · Answer 2 · 2019-03-07T15:56:11.527

1

Would a SUMIF function work for you?

The two sheets are in the same book, right?

=SUMIF($A$6:$A$10, B$1,$C$6:$C$10)

=

Regarding your particular error, I am pretty sure excel does not go to ZZZ. It only goes up to XFD (16,384).

On the new error, it does not look like you are copying anything before trying to paste. Try this:

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

edited Mar 07 '19 at 15:56

answered Mar 07 '19 at 14:07

CATSandCATSandCATS

302
4
12

Thank you. Unfortunately, that won't help for two reasons. I have non-numerical fields that I'd like to return and neither the fields in master nor the fields in data are fixed. – gnosys101 Mar 07 '19 at 14:18
@gnosys101, updated for your new error. Give it a look? – CATSandCATSandCATS Mar 07 '19 at 15:56
Thanks for this. I tried it and it looks like it's copying fields from master and pasting them in the offset position within the same sheet. It does this for a couple of fields and then errors with that initial 'Application-defined or object-defined error' error. I think the problem is my rookie code which is the issue – gnosys101 Mar 07 '19 at 16:33

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

2 Answers2