How to loop a macro?

  • Thread starter Thread starter a
  • Start date Start date
A

a

I need to manipulate an excel file that contains relay results from a summer
swim leauge. I need to take a row that looks like this:

TEAM DATE MEET SWIMMER1 SWIMMER2 SWIMMER3 SWIMMER4

and turn it into 4 rows that look like this

SWIMMER1 TEAM DATE MEET
SWIMMER2 TEAM DATE MEET
SWIMMER3 TEAM DATE MEET
SWIMMER4 TEAM DATE MEET

I got as far as creating the macro below but it keeps going back to the same
line 6 and repeaqting the insert...

How do I modify this to go to the next line down?

Is it possible to loop the macro so that it will process all 1300 lines in
my spreadsheet?

The currnet Macro looks like:

Sub AMSA()
'
' AMSA Macro
' Macro recorded 7/7/2007 by cduchon
'
' Keyboard Shortcut: Ctrl+Shift+A
'
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("A6:C6").Select
Range("C6").Activate
Selection.Copy
Range("A7:C9").Select
ActiveSheet.Paste
Range("E6").Select
Application.CutCopyMode = False
Selection.Copy
Range("D7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F6").Select
Application.CutCopyMode = False
Selection.Copy
Range("D8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("G6").Select
Application.CutCopyMode = False
Selection.Copy
Range("D9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A10").Select
End Sub
 
Option Explicit

Sub ProcessData()
Dim iLastrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

iLastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastrow To 2 Step -1
.Rows(i + 1).Resize(3).Insert
.Cells(i + 1, "A").Value = .Cells(i, "D").Value
.Cells(i + 1, "B").Value = .Cells(i, "A").Value
.Cells(i + 1, "C").Value = .Cells(i, "B").Value
.Cells(i + 1, "D").Value = .Cells(i, "C").Value
.Cells(i + 2, "A").Value = .Cells(i, "E").Value
.Cells(i + 2, "B").Value = .Cells(i, "A").Value
.Cells(i + 2, "C").Value = .Cells(i, "B").Value
.Cells(i + 2, "D").Value = .Cells(i, "C").Value
.Cells(i + 3, "A").Value = .Cells(i, "F").Value
.Cells(i + 3, "B").Value = .Cells(i, "A").Value
.Cells(i + 3, "C").Value = .Cells(i, "B").Value
.Cells(i + 3, "D").Value = .Cells(i, "C").Value
.Cells(i, "A").Insert Shift:=xlToRight
.Cells(i, "A").Value = .Cells(i, "E").Value
.Cells(i, "E").Resize(, 4).ClearContents
Next i
End With
End Sub
 
Thanks.

Bob Phillips said:
Option Explicit

Sub ProcessData()
Dim iLastrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

iLastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastrow To 2 Step -1
.Rows(i + 1).Resize(3).Insert
.Cells(i + 1, "A").Value = .Cells(i, "D").Value
.Cells(i + 1, "B").Value = .Cells(i, "A").Value
.Cells(i + 1, "C").Value = .Cells(i, "B").Value
.Cells(i + 1, "D").Value = .Cells(i, "C").Value
.Cells(i + 2, "A").Value = .Cells(i, "E").Value
.Cells(i + 2, "B").Value = .Cells(i, "A").Value
.Cells(i + 2, "C").Value = .Cells(i, "B").Value
.Cells(i + 2, "D").Value = .Cells(i, "C").Value
.Cells(i + 3, "A").Value = .Cells(i, "F").Value
.Cells(i + 3, "B").Value = .Cells(i, "A").Value
.Cells(i + 3, "C").Value = .Cells(i, "B").Value
.Cells(i + 3, "D").Value = .Cells(i, "C").Value
.Cells(i, "A").Insert Shift:=xlToRight
.Cells(i, "A").Value = .Cells(i, "E").Value
.Cells(i, "E").Resize(, 4).ClearContents
Next i
End With
End Sub
Click to expand...
 
Here's my technique on doing something similar:

Sub Demo()
Dim D As Variant
Dim R As Long '(R)ow
Dim C As Long '(C)olumn
Dim M As Variant
Dim Rec As Long

Set D = CreateObject("Scripting.Dictionary")

M = [A1].CurrentRegion.Value
For R = 2 To UBound(M, 1)
For C = 4 To 7
Rec = Rec + 1
D.Add Rec, Array(M(R, C), M(R, 1), M(R, 2), M(R, 3))
Next C
Next R

[A1].CurrentRegion.Clear
[A2].Resize(D.Count, 4) = T2(D.items)
With [A1:D1]
.Value = Array("Swimmer", "Team", "Date", "Meet")
.EntireColumn.AutoFit
End With
End Sub

' T2 is one of my common Library Functions:

Private Function T2(v)
' Transpose twice.
With WorksheetFunction
T2 = .Transpose(.Transpose(v))
End With
End Function
 
Back
Top