Tietojen siirto tyyppinumeron perusteella

moduuliin...
muuttele taulukoiden nimet sopiviksi

Option Explicit
Dim EiTupla As New Collection
Sub Kopioi()
Dim Tiedot As Variant
Dim Alue As Range
Dim i As Integer
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Sheet1").Activate
Worksheets("Sheet2").Cells.Clear
PoistaTuplat
For i = 1 To EiTupla.Count
Set Alue = EtsiJaSiirrä(EiTupla(i), Columns("A")).Offset(0, 1)
Tiedot = Alue
Tiedot = Application.WorksheetFunction.Transpose(Tiedot)
Range("Sheet2!A" & i) = EiTupla(i)
Range("Sheet2!B" & i).Resize(Alue.Columns.Count, Alue.Rows.Count) = Tiedot
Next i
Worksheets("Sheet2").Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub PoistaTuplat()
Dim solu As Range
Dim Vika As Double
On Error GoTo virhe
Vika = Range("A65536").End(xlUp).Row
For Each solu In Range("A1:A" & Vika)
If Not IsEmpty(solu) Then
EiTupla.Add solu.Value, CStr(solu.Value)
End If
Next solu
Exit Sub
virhe:
Resume Next
End Sub
Function EtsiJaSiirrä(Haettava As Variant, _
Hakualue As Range) As Range

Dim solu As Range
Dim ekaosoite As String

With Hakualue
Set solu = .Find( _
What:=Haettava, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrä = solu
ekaosoite = solu.Address
Do
Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address ekaosoite
End If
End With
End Function