PDA

View Full Version : [SOLVED] Transpose Excel data from rows to columns



parscon
12-14-2017, 04:02 AM
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 .

21174

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

p45cal
12-14-2017, 09:53 AM
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.)

parscon
12-14-2017, 10:13 AM
Hello , Thanks for your help but it is not my mean , if you check the attached image you understand what i need .

p45cal
12-14-2017, 10:39 AM
Point out the differences:
21179
After my offering:
21180

parscon
12-14-2017, 11:09 PM
Hello , Please check the attached Excel File , in Sheet 2 is our result , if you see it you will understand .

21182

p45cal
12-15-2017, 08:31 AM
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.)

parscon
12-15-2017, 01:13 PM
Really appreciate for your great help .