Option Explicit
Sub CopyAll()
Dim Sh As Worksheet, Rng As Range, Clls As Range, sRng As Range
Dim Cll As Range, Rng0 As Range
Dim Jj As Byte, Dg As Byte
Dim MyAdd As String
Sheet1.Select: Set Sh = Sheet2
Set Rng = Range([B4], [B65500].End(xlUp))
Set Clls = Rng.Offset(1, 4)
For Jj = 0 To 5 Step 4
Rng.Offset(, Jj).AdvancedFilter Action:=2, CopyToRange:=[H1].Offset(, Jj / 2), _
Unique:=True
Next Jj
Sh.[A4].CurrentRegion.Offset(, 1).ClearContents
Sh.[A4].Resize(, 4).Value = [A4].Resize(, 4).Value
[j2].CurrentRegion.Offset(1).Copy
Sh.[iv4].End(xlToLeft).Offset(, 1).PasteSpecial , Transpose:=True
Application.CutCopyMode = False
Set Rng0 = Sh.Range(Sh.[c4], Sh.[iv4].End(xlToLeft))
For Each Clls In Range([H2], [H2].End(xlDown))
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
With Sh.[B65500].End(xlUp).Offset(1)
If .Offset(-1, 1).Value = sRng.Offset(, 1).Value Then
Dg = 1
Else
.Resize(, 3).Value = sRng.Resize(, 3).Value
Dg = 0
End If
For Each Cll In Rng0
If Cll.Value = sRng.Offset(, 4).Value Then
Sh.Cells(.Row - Dg, Cll.Column).Value = sRng.Offset(, 3).Value
Exit For
End If
Next Cll
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Next Clls
Sh.Select
End Sub
