Help transposing data

[lwilt]

Please help me be able to transpose the data in the workbook I attached. One sheet has what it would currently look like (in the actual file it's about 3,000 lines) and the 2nd sheet shows how I'd like it to look.

Also posted this at:
http://www.excelforum.com/excel-programming-vba-macros/1129119-transpose-help.html

http://www.mrexcel.com/forum/excel-questions/925444-help-transposing-data.html

 

[Nebu]

Hi:

Find the code.

Sub test()

Application.ScreenUpdating = False
Dim rng As Range, fnd As Range, fnd1 As Range

Set rng = Me.Range("A2:B" & Me.Cells(Rows.Count, "A").End(xlUp).Row)
For i& = 2 To Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
    Set fnd = rng.Find(What:=Sheet2.Range("A" & i))
        If Not fnd Is Nothing Then
            Set fnd1 = fnd
            l& = 2
            Sheet2.Cells(i, l) = Me.Cells(fnd.Row, 2)
                Do
                    Set fnd = rng.FindNext(After:=fnd)
                        If fnd.Address = fnd1.Address Then
                            Exit Do
                        Else
                        l = l + 1
                        Sheet2.Cells(i, l) = Me.Cells(fnd.Row, 2)
                    End If
                Loop
        End If
Next
Application.ScreenUpdating = True

End Sub

Thanks

 

[YasserKhalil]

Thanks a lot Mr. Nebu for this wonderful solution
I think you depend on the Sheet2.Range("A2:A" & LastRow) ..
But I think lwilt need the full results so this code would be put in the sheet1 module and called first of your code

Sub GetUniqueValues()
    Dim myData As Variant, Temp As Variant
    Dim Obj As Object, I As Long
   
    Set Obj = CreateObject("Scripting.Dictionary")
    myData = Me.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
    For I = 1 To UBound(myData)
        Obj(myData(I, 1) & "") = ""
    Next I
   
    Temp = Obj.Keys
   
    Sheet2.Range("A2").Resize(Obj.Count, 1) = Application.Transpose(Temp)
    Set Obj = Nothing
End Sub

This would extract unique items of the range("A2:A" & lastrow) in Sheet1 and put results in A2 in Sheet2 .. then the task would be complete now
Regards

 

[Nebu]

@YasserKhalil

if you add the following code after the Dim statement of the code I have given , it will achieve the same as your code.

Me.Range("A2:A" & Me.Cells(Rows.Count, "A").End(xlUp).Row).Copy
    Sheet2.[A2].PasteSpecial
    Application.CutCopyMode = False
    Sheet2.Range("$A$2:$A$" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo

Thanks

 

[Marc L]

Hi !

First, the Match way :​

Sub Demo1()
                            L& = 1
    Application.ScreenUpdating = False
    Sheet2.UsedRange.Clear
With Sheet1.UsedRange.Rows
           .Item(1).Copy Sheet2.Cells(1)
    For R& = 2 To .Count
         V = Application.Match(.Cells(R, 1).Value, Sheet2.UsedRange.Columns(1), 0)
        If IsError(V) Then
                         L = L + 1
            Sheet2.Cells(L, 1).Resize(, 2).Value = .Item(R).Value
        Else
            Sheet2.Cells(V, 1).End(xlToRight).Offset(, 1).Value = .Cells(R, 2).Value
        End If
    Next
End With
    Sheet2.UsedRange.Columns.AutoFit
    Application.Goto Sheet2.Cells(1), True
    Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[Marc L]

Second, matching Array variables :​

Sub Demo2()
    VA = Sheet1.UsedRange.Value
    ReDim AV(1 To UBound(VA), 0), BV(1 To UBound(VA), 0)
          AV(1, 0) = VA(1, 1):    BV(1, 0) = VA(1, 2)
                L& = 1
For R& = 2 To UBound(VA)
               V = Application.Match(VA(R, 1), AV, 0)
    If IsError(V) Then
               L = L + 1
        AV(L, 0) = VA(R, 1)
        BV(L, 0) = VA(R, 2)
    Else
        BV(V, 0) = BV(V, 0) & vbTab & VA(R, 2)
    End If
Next
    With Sheet2
             .UsedRange.Clear
        With .[A1:B1].Resize(L).Columns
             .Item(1).Value = AV
             .Item(2).Value = BV
             .Item(2).TextToColumns
        End With
             .UsedRange.Columns.AutoFit
             Application.Goto .Cells(1), True
    End With
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[Marc L]

Third, the Dictionary way (Windows only but fastest the more rows) :​

Sub Demo3()
    VA = Sheet1.UsedRange.Value
    Sheet2.UsedRange.Clear
With CreateObject("Scripting.Dictionary")
        .Item(VA(1, 1)) = VA(1, 2)
    For R& = 2 To UBound(VA)
        .Item(VA(R, 1)) = .Item(VA(R, 1)) & VA(R, 2) & vbTab
    Next
        Sheet2.[A1:B1].Resize(.Count).Value = Application.Transpose(Array(.Keys, .Items))
        .RemoveAll
End With
    With Sheet2.UsedRange.Columns
        .Item(2).TextToColumns
        .AutoFit
        Application.Goto .Cells(1), True
    End With
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[lwilt]

solved. thanks for all the help. really appreciate it.