Snasui Excel Forum

Code: Select all

Sub TransposePaste()
Dim Int1 As Integer, Int2 As Integer
Dim Int3 As Integer
Dim rRange1 As Range
Dim rRange2 As Range, rRange3 As Range
    With ActiveSheet
        .Range("E:IV").ClearContents
        .Range("A:A").Copy
        .Range("E:E").PasteSpecial xlPasteValues
        .Range("E:E").RemoveDuplicates Columns:=1, Header:=xlNo
        .Range("E1").ClearContents
        Set rRange2 = .Range("E2", .Range("E65536").End(xlUp))
    End With
    For Each rRange1 In rRange2
        Int3 = Application.WorksheetFunction. _
            Match(rRange1, Range("A:A"), 0)
        Int2 = Application.WorksheetFunction. _
            CountIf(Range("A:A"), rRange1)
        Set rRange3 = Range("A1").Offset(Int3 - 1, 1).Resize(Int2, 1)
        rRange3.Copy
        rRange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Next
    Application.CutCopyMode = False
    MsgBox "Fish"
End Sub

Code: Select all

Sub TransposePaste()
Dim Int1 As Integer, Int2 As Integer
Dim Int3 As Integer
Dim rRange1 As Range
Dim rRange2 As Range, rRange3 As Range
    With ActiveSheet
        .Range("E:IV").ClearContents
        .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "E1"), Unique:=True
        .Range("E1").ClearContents
        Set rRange2 = .Range("E2", .Range("E65536").End(xlUp))
    End With
    For Each rRange1 In rRange2
        Int3 = Application.WorksheetFunction. _
            Match(rRange1, Range("A:A"), 0)
        Int2 = Application.WorksheetFunction. _
            CountIf(Range("A:A"), rRange1)
        Set rRange3 = Range("A1").Offset(Int3 - 1, 1).Resize(Int2, 1)
        rRange3.Copy
        rRange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Next
    Application.CutCopyMode = False
    MsgBox "Finish"
End Sub