Text to column and paste special transpose

[isfaruddin sapardi]

Hi All,

I have 1 table like this


item_number qty ref
00010-001 3 U34,U36,U43
00013-001 2 U16,U21
12505-001 3 U32,U33,U42
12512-001 3 U5,U6,U27

and 1 want it to become like this

item_number qty ref
00010-001 3 U34
00010-001 3 U36
00010-001 3 U43
00013-001 2 U16
00013-001 2 U21
12505-001 3 U32
12505-001 3 U33
12505-001 3 U42
12512-001 3 U5
12512-001 3 U6
12512-001 3 U27

Anybody can help me to program it in macro.. usually i do it manually and have to redo again do to careless.

 

[Gord Dibben]

After using Text to Columns on Column C.......comma
delimited.........Run the Reorganize macro.

Sub ReOrganize()
Dim LR As Long, I As Long, r As Long, c As Long, v As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
I = 2
Do Until Range("A" & I) = ""
If Range("C" & I) <> "" Then
c = Cells(I, Columns.Count).End(xlToLeft).Column
v = I
For r = 3 To c
I = I + 1
Rows(I).Insert xlShiftDown
Range("A" & I) = Range("A" & I - 1)
Range("C" & I) = Cells(v, r)
Next r
End If
I = I + 1
Loop
Range("D1", Cells(Rows.Count, Columns.Count)).ClearContents
Call Fill_Blanks
Application.ScreenUpdating = True
End Sub

Sub Fill_Blanks()
Dim wks As Worksheet
Dim rng As Range
Dim lastrow As Long
Dim Col As Long
Set wks = ActiveSheet
With wks
Col = .Range("B1").Column
Set rng = .UsedRange
lastrow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rng = Nothing
On Error Resume Next
Set rng = .Range(.Cells(2, Col), .Cells(lastrow, Col)) _
.Cells.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "No blanks found"
Exit Sub
Else
rng.NumberFormat = "General"
rng.FormulaR1C1 = "=R[-1]C"
End If
With .Cells(1, Col).EntireColumn
.Value = .Value
End With
End With
End Sub


Gord