Thread: Need Macro Help
View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.misc
excelmad excelmad is offline
external usenet poster
 
Posts: 9
Default Need Macro Help

I want the following Macro to copy information from column A:F based on a
repeat reference in column A, paste data beginning in the column G, Add a
sheet, paste in new sheet, go back to Sheet1 and delete A:F. All is working
fine except the Macro is only copying the information in columns A and B.

What do I need to do to get my desired result?

SAMPLE DATA
Column A Column B Column C Column D Column E Column F
111-11-1111 John Andrews Chicago CS Tech
111-11-1111 Daniel Edwards Philadelphia IT Mgr
222-22-2222 Elias Martin Charlotte IT Sup
333-33-3333 Augusta Clemens Philadelphia CS Tech
333-33-3333 Jaime Turner Boston IT Sup
333-33-3333 Wayne Norriston Atlanta DR Dir
RESULT I RECEIVE WITH THE MACRO BELOW:
Column A Column B Column C Column D Column E Column F
111-11-1111 John Daniel
222-22-2222 Elias
333-33-3333 Augusta Jaime Wayne CS Tech
RESULT I WANT:
Column A Column B Column C Column D Column E Column F Column G Column
H Column I Column J Column K Column L Column M Column N Column O Column P
111-11-1111 John Andrews Chicago CS Tech Daniel Edwards Philadelphia IT Mgr
222-22-2222 Elias Martin Charlotte IT Sup
333-33-3333 Augusta Clemens Philadelphia CS Tech Jaime Turner Boston IT Sup Wayne Norriston Atlanta DR Dir

Sub ReArrange()
Dim FirstCell As Range
Dim LastCell As Range
Dim Dest As Range
Dim c As Long
Set FirstCell = Range("A1")
Do Until FirstCell.Value = ""
For c = 1 To 20
If FirstCell.Offset(c).Value < FirstCell.Value Then
Set LastCell = FirstCell.Offset(c - 1)
Set Dest = Range("G" & Rows.Count).End(xlUp).Offset(1)
Exit For
End If
Next c
Dest.Value = FirstCell.Value
For c = 1 To Range(FirstCell, LastCell).Count
Dest.Offset(, c).Value = FirstCell.Offset(c - 1, 1).Value
Next c
Set FirstCell = LastCell.Offset(1)
Loop
Columns("A:F").Select
Columns("A:F").Copy
Sheets.Add
Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("A:F").Delete
MsgBox "Run Complete"
End Sub