Sub Transpose3()
Dim lastRow As Long
Dim R1 As Range
Dim R2 As Range
Dim R3 As Range
Dim RowN As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
Sheets.Add After:=ActiveSheet
ActiveSheet.Range("A1").Select
' ----------------- this is just naming the headers on the new sheet "Data Results" you can add more data columns in D1 and beyond by copying these and changing them to the appropriate cells -----------------------
ActiveCell.FormulaR1C1 = "ID#"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Data1"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Data2"
ActiveSheet.Name = "Data Results"
ws.Select
lastRow = Range("D" & Rows.Count).End(xlUp).Row
' ----------------- A2:C below here refers to the range of your IDs, you can change this to fit your needs --------------
Set R1 = Range("A2:C" & lastRow)
Set R2 = Sheets("Data Results").Range("A2")
RowN = 0
Application.ScreenUpdating = False
For Each R3 In R1.Rows
R3.Copy
R2.Offset(RowN, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
RowN = RowN + R3.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("Data Results").Select
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' ---------------------- Everything below this point are the vlookups, Range B2 is Data 1 or the first cell of data. Change "Sheet1" to match the sheet name where the IDs and Data is wherever you see it. C1:C4 refers to columns 1-4 as the lookup range, and the ", 4, false" is telling us we want the 4th column returned as the value. Change these ranges based on your needs. Note that the first column you look up must contain the ID and the last column must be the Data ----------------------------------
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]="""","""",IFERROR(VLOOKUP(RC[-1],Sheet1!C1:C4,4,FALSE),IFERROR(VLOOKUP(RC[-1],Sheet1!C2:C5,3,FALSE),IFERROR(VLOOKUP(RC[-1],Sheet1!C3:C4,2,FALSE),""""))))"
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("B2").AutoFill Destination:=Range("B2:B" & lastRow)
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' --------------------- Range C2 is like B2 but for Data2 --------------------------
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]="""","""",IFERROR(VLOOKUP(RC[-2],Sheet1!R1:R1048576,5,FALSE),IFERROR(VLOOKUP(RC[-2],Sheet1!C2:C5,4,FALSE),IFERROR(VLOOKUP(RC[-2],Sheet1!C3:C5,3,FALSE),""""""""))))"
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2").AutoFill Destination:=Range("C2:C" & lastRow)
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub