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
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