mateenmohd,
Here you go.
Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).
Press and hold down the 'ALT' key, and press the 'F11' key.
Insert a Module in your VBAProject, Microsoft Excel Objects.
Copy the below code, and paste it into the Module1.
Code:
Option Explicit
Sub Test()
' original code by jindon
' modified by stanleydgromjr
'
Dim a, i As Long, y, w(), myMax As Integer
With ActiveSheet
With .Range("a1").CurrentRegion.Resize(, 2)
a = .Value
.ClearContents
End With
With CreateObject("Scripting.Dictionary")
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
myMax = WorksheetFunction.Max(myMax, UBound(w))
End If
Next
y = .items
End With
With .Range("a1")
.Value = "Machine"
.Offset(, 1).Resize(, myMax).Value = "Text"
For i = 0 To UBound(y)
.Offset(i).Resize(, UBound(y(i)) + 1).Value = y(i)
Next
End With
End With
End Sub
Then run the "Test" macro.
Have a great day,
Stan
stanleydgromjr
Windows Vista Business and Excel 2003, 2007.
Macro in Excel
