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

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

Answer 1

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

Answer 2

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