Help with optimizing VBA code

[andyfleisher]

Hi there. First off, the code I made did what I needed it to do but I am looking for ways/tips on creating it in a better way and not having eat up my computer's memory. Most of what I did was just using the macro recorder and adjusting the output to my needs along with some Google searches for trickier parts. A ton of what I found seemed to say NOT to use ".select" commands but that seems to be exactly what the macro recorder likes to do. The goal of this macro was just to manipulate data from a survey into a different layout. It could have been done by hand but it would have taken way too long. The basic data is below and it is just a tiny sample, there were up to 88 columns of data if the people filled out everything on the survey (which no one really did). There were also blank spots within each row depending if people filled out say all 10 of the options (they were listing different people and some listed more or less than others).

Before

First	Last	Email	Category	First	Last	Email	Category	First	Last	Email	Category
Cust 1	Last	Cust1@email.com	Learner	P1	Last	P1email	Customer	P2	Last	P2email	Supervisor
Cust 2	Last	Cust2@email.com	Learner	P3	Last	P3email	Boss
Cust 3	Last	Cust3@email.com	Learner	P4	Last	P4email	Customer	P5	Last	P5email	Boss

<tbody>
</tbody>

After

First	Last	Email	Category	First	Last	Email	Category
Cust 1	Last	Cust1@email.com	Learner	P1	Last	P1email	Customer
				P2	Last	P2email	Supervisor
First	Last	Email	Category	First	Last	Email	Category
Cust 2	Last	Cust2@email.com	Learner	P3	Last	P3email	Boss
First	last	Email	Category	First	Last	Email	Category
Cust 3	Last	Cust3@email.com	Learner	P4	Last	P4email	Customer
				P5	Last	P5email	Boss

<tbody>
</tbody>

All of the data starts at A1 and the code I created to cycle through all of the data to move it around and add the headings to each new person is below. When run, you would place the selection on A2 and run the macro. Once it is finished, there is some extraneous data/cells to clean up but instead of copying/pasting/transposing for hours, this takes just a few minutes. Of course after it has run, Excel seems to be super slow and bogged down and I have a feeling it is from the poorly optimized code. Thanks for the help.

Sub CornFerry_Formatting()
'
' This manipulates the data from a standard flat file into a format that CornFerry likes.
' The rater is listed off to the left and all of the other pertinant data is listed to the right.
 
'
' The initial selection needs to be the first name of the first data point
    Dim i As Integer
    Dim DelRange As String
    Dim StartRow As Integer
    Dim EndRow As Integer
' This looks to see if the right adjacent cell is empty, if it IS NOT,
' the macro keeps running.
    Do While IsEmpty(ActiveCell.Offset(0, 1)) = False
' This adds 90 blank rows below the first line of data.
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Rows("1:90").EntireRow.Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' This copy and transposes the first line of data.
    ActiveCell.Offset(-1, 0).Range("A1:CJ1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
' This removes the first 8 lines of the transposed data since it is still
' correct after being transposed.
    ActiveCell.Range("A1:A8").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveCell.Offset(8, 0).Range("A1").Select
' This looks at the current AND adjacent cells.
' If the current cell AND adjacent cell is blank, the macro will stop.
' If the current cell is not blank but the adjacent cell is, the macro
' keeps running.
    Do While IsEmpty(ActiveCell.Offset(0, 1)) And Not IsEmpty(ActiveCell.Offset(0, 0)) = True
' This selects the 4 rows of data and transposes it back to the correct spot.
    ActiveCell.Range("A1:A4").Select
    Selection.Copy
    ActiveCell.Offset(0, 4).Range("A1").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
' This removes the original 4 rows. and moves down to the next spot to loop
' through again if needed.
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Range("A1:A4").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Selection.End(xlDown).Select
    Loop
' Once finished with the data, this delets the extra rows of blank cells
' leaving a single blank line between each original data entry.
    ActiveCell.Offset(-1, 4).Range("A1").Activate
    Selection.End(xlUp).Select
    Selection.End(xlToLeft).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveCell.Rows.EntireRow.Resize(Selection.Rows.Count - 3, Selection.Columns.Count).Select
    Selection.Delete Shift:=xlUp
    ActiveCell.Select
    Selection.End(xlDown).Select
' This adds headings to the new data. and places the selection in the correct
' spot to start all over until the macro ends.
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "First Name"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Last Name"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Email"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Category"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "First Name"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Last Name"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Email"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Category"
    Selection.End(xlToLeft).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Loop
End Sub

Andy Fleisher