Sub ReorgDataV3()
' hiker95, 07/28/2015, ME871309
Dim w1 As Worksheet, wr As Worksheet
Dim o As Variant, j As Long, c As Long
Dim r As Long, lr As Long, rr As Long, n As Long, nmax As Long, ng As Long, t As String
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1") '<-- you can change the sheet name here
With w1
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
ng = ng + 1
n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
If IsNumeric(.Cells(r, 1)) Then
t = .Cells(r, 1).Value
With .Range(.Cells(r, 1), .Cells(r + n - 1, 1))
.NumberFormat = "@"
.Value = "00" & t
End With
End If
If n > nmax Then nmax = n
r = r + n - 1
Next r
ReDim o(1 To ng, 1 To (nmax * 2) + 1)
For r = 1 To lr
n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
j = j + 1: c = 1
o(j, 1) = .Cells(r, 1).Value
For rr = r To r + n - 1
c = c + 1
o(j, c) = .Cells(rr, 2).Value
c = c + 1
o(j, c) = .Cells(rr, 3).Value
Next rr
r = r + n - 1
Next r
End With
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
wr.UsedRange.Clear
With wr
.Cells(1, 1).Resize(UBound(o, 1)).NumberFormat = "@"
.Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
.Columns(1).Resize(, UBound(o, 2)).AutoFit
.Activate
End With
Application.ScreenUpdating = False
End Sub
