Change from Horizontal Multiples to Vertical Multiples

[callmeshirley]

I have these numbers:
Billy 10 15 24
Sally 18 10 6
Ahmad 30 2 18

& I need them formatted as so:

Billy 10
Billy 15
Billy 24
Sally 18
Sally 10
Sally 6
Ahmad 30
Ahmad 2
Ahmad 18

How is the easiest way to do this? Every month I retype all 2000 entries and there has to be an easier way.
Thanks in advance.

 

[hiker95]

callmeshirley,


Sample raw data in worksheet Sheet1 before the macro:

Excel Workbook
	A	B	C	D	E
1	Billy	10	15	24
2	Sally	18	10	6
3	Ahman	30	2	18
4
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B
1	Billy	10
2	Billy	15
3	Billy	24
4	Sally	18
5	Sally	10
6	Sally	6
7	Ahman	30
8	Ahman	2
9	Ahman	18
10
Results

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


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 06/28/2011
' http://www.mrexcel.com/forum/showthread.php?t=560559
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, a As Long, n As Long, LC As Long, NR As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
NR = 1
LR = w1.Cells(Rows.Count, 1).End(xlUp).Row
For a = 1 To LR Step 1
  LC = w1.Cells(a, Columns.Count).End(xlToLeft).Column
  n = LC - 1
  wR.Range("A" & NR).Resize(n).Value = w1.Cells(a, 1).Value
  wR.Range("B" & NR).Resize(n).Value = Application.Transpose(w1.Range(w1.Cells(a, 2), w1.Cells(a, LC)).Value)
  NR = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
Next a
wR.UsedRange.Columns.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[callmeshirley]

THIS WORKED PERFECTLY!!!!

This site rocks!!! Saved me hours!

 

[hiker95]

callmeshirley,

Glad I could help.

Thanks for the feedback.

Come back anytime.