Excel Macro to loop a script

**JFN** · 26-04-2010

Hi guys, I'm new to VBA and I need to make a loop to simplify the following script, but I don't have full kowledge of VBA if anyone can help guiding me I will appreciate it.

Thank you.

JFN

Sub FindMonth()
Dim intS As Integer
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet

Windows("Bandwidth.xls").Activate

Application.ScreenUpdating = False

Sheets("Sheet1").Select

intS = 1

'This step assumes that you have a worksheet named Dec1

Set wSht = Worksheets("Dec1")
strToFind = "2009-12"

'Change this range to suit your own needs.

With ActiveSheet.Range("A1:K50000")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.EntireRow.Copy wSht.Cells(intS, 1)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheets("Sheet2").Select

intS = 1

'This step assumes that you have a worksheet named Dec2

Set wSht = Worksheets("Dec2")
strToFind = "2009-12"

'Change this range to suit your own needs.
With ActiveSheet.Range("A1:K50000")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.EntireRow.Copy wSht.Cells(intS, 1)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheets("Sheet3").Select

intS = 1

'This step assumes that you have a worksheet named Dec3

Set wSht = Worksheets("Dec3")
strToFind = "2009-12"

'Change this range to suit your own needs.
With ActiveSheet.Range("A1:K50000")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.EntireRow.Copy wSht.Cells(intS, 1)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheets("Sheet4").Select

intS = 1
'copy results to the same sheet
' intS = wSht.UsedRange.Rows.Count + 1

'This step assumes that you have a worksheet named
'Search Results.
Set wSht = Worksheets("Dec4")
strToFind = "2009-12"

'Change this range to suit your own needs.
With ActiveSheet.Range("A1:K50000")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.EntireRow.Copy wSht.Cells(intS, 1)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''
'ETC ETC etc ................................. up to 160 sheets

End Sub

**Solaris** · 27-04-2010

Hello,
See if the following code can help you

Code:

Sub Macro1()
'
' Macro1 Macro
'    ActiveCell.Offset(1, 0).Range("A1:A3").Select
    Selection.EntireRow.Insert
    ActiveCell.Offset(-1, 1).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(1, -1).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 2).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(2, -2).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(2, 0).Range("A1").Select
End Sub