Consulting

Results 1 to 7 of 7

Thread: Transpose Excel data from rows to columns

  1. #1
    VBAX Mentor
    Joined
    Feb 2012
    Posts
    406
    Location

    Unhappy Transpose Excel data from rows to columns

    Hello I have Data like below image , i need Transpose Excel data from rows to columns with base Column A , Mean if the column A are same do that .
    If you see the image you can understand fully . If you can provide a VBA for this really will help me so much . (Important :I need do for the row that their A column Are same )
    The data that i have are till I column .

    Sheet.jpg

    I have the below code but it is only work on column B i need do the same From B To I Column
    Option Explicit
    Sub Test()
        Dim a, i As Long, y, w()
        a = ThisWorkbook.Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 2).Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = vbTextCompare
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), Array(a(i, 1), a(i, 2))
                Else
                    w = .Item(a(i, 1))
                    ReDim Preserve w(UBound(w) + 1)
                    w(UBound(w)) = a(i, 2)
                    .Item(a(i, 1)) = w
                End If
            Next
            y = .items
        End With
        With ThisWorkbook.Sheets("Sheet2").Range("a1")
            .CurrentRegion.Clear
            For i = 0 To UBound(y)
                .Offset(i).Resize(, UBound(y(i)) + 1).Value = y(i)
            Next
        End With
    End Sub
    Last edited by parscon; 12-14-2017 at 04:36 AM.

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Sub blah()
    Set SourceRng = Sheets("Sheet1").Range("A1").CurrentRegion
    Set DestnRng = Sheets("Sheet2").Range("A1")
    With SourceRng
      .Columns(1).Copy DestnRng
      Intersect(.Offset(0, 0), .Offset(, 1)).Copy
      DestnRng.Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
      Application.CutCopyMode = False
    End With
    End Sub
    ?
    (No clearing of the destination cells.)
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    VBAX Mentor
    Joined
    Feb 2012
    Posts
    406
    Location
    Hello , Thanks for your help but it is not my mean , if you check the attached image you understand what i need .
    Attached Images Attached Images

  4. #4
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Point out the differences:
    2017-12-14_173744.JPG
    After my offering:
    2017-12-14_173823.JPG
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  5. #5
    VBAX Mentor
    Joined
    Feb 2012
    Posts
    406
    Location
    Hello , Please check the attached Excel File , in Sheet 2 is our result , if you see it you will understand .

    Sample.xlsx

  6. #6
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Ahh, moving goalposts again.
    Try these two (only run blah, it calls the other):
    Sub blah()
    Set mydata = Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
    Set Destn = Sheets("Sheet2").Range("A1")
    mydatavals = mydata.Value
    Count = 1: StartBlock = 1
    For i = 1 To UBound(mydatavals) - 1
      If mydatavals(i, 1) = mydatavals(i + 1, 1) Then
        Count = Count + 1
      Else
        MoveStuff mydata.Cells(StartBlock, 1).Resize(Count, 9), Destn
        Set Destn = Destn.Offset(8)
        StartBlock = StartBlock + Count: Count = 1
      End If
    Next i
    MoveStuff mydata.Cells(StartBlock, 1).Resize(Count, 9), Destn
    End Sub
    
    Sub MoveStuff(SourceRange, DestnRange)
    DestnRange.Resize(8, 1).Value = SourceRange.Cells(1).Value
    Intersect(SourceRange, SourceRange.Offset(, 1)).Copy
    DestnRange.Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    End Sub
    (No clearing of the destination cells.)
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  7. #7
    VBAX Mentor
    Joined
    Feb 2012
    Posts
    406
    Location
    Really appreciate for your great help .

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •