Help with loop sequence

Hi.

I could use some help setting up a loop sequence for my macro(macro as
it is can be seen below).

I need the macro to loop the sequence for a number of times until
there is only empty rows in range B9:B35. Is that possible?
Alternatively is it possible to enter the number of times the loop
should repeat itself in a cell and have the macro read this number?

Any help will be appreciated.

-- Macro--
Sub FindCell()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending, Header:=
_
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

myValue = Range("J3").Value
For Each cell In Range("B9:B35")
If cell.Value myValue Then
cell.Select
ActiveCell.EntireRow.Select
Selection.Cut
Sheets("Dataark").Select
Range("A3").Select
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Paste

Set rng = Cells(Rows.Count, 2).End(xlUp)
rng.Select
ActiveCell.Copy
Sheets("CM").Select
Range("K3").Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 2

Range("J3").Select
ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"

Exit Sub
End If
Next
End Sub

-- Macro End--


//Kasper

1.
Sub FindCell()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending,
Header:=
_
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
myValue = Range("J3").Value
For Each cell In Range("B9:B35")
If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then
If cell.Value myValue Then
cell.Select
ActiveCell.EntireRow.Select
Selection.Cut
Sheets("Dataark").Select
Range("A3").Select
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Paste
Set rng = Cells(Rows.Count, 2).End(xlUp)
rng.Select
ActiveCell.Copy
Sheets("CM").Select
Range("K3").Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 2
Range("J3").Select
ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"
Exit Sub
End If
End If
Next cell
End Sub

2. presuming the number for the loop to be repeated is in K3

Sub FindCell()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending,
Header:=
_
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
myValue = Range("J3").Value
For i =1 to Range("K3").Value
For Each cell In Range("B9:B35")
If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then
If cell.Value myValue Then
cell.Select
ActiveCell.EntireRow.Select
Selection.Cut
Sheets("Dataark").Select
Range("A3").Select
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Paste
Set rng = Cells(Rows.Count, 2).End(xlUp)
rng.Select
ActiveCell.Copy
Sheets("CM").Select
Range("K3").Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 2
Range("J3").Select
ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"
Exit Sub
End If
End If
Next cell
Next i
End Sub

On 16 Gru, 11:06, Kasper wrote:
Hi.

I could use some help setting up a loop sequence for my macro(macro as
it is can be seen below).

I need the macro to loop the sequence for a number of times until
there is only empty rows in range B9:B35. Is that possible?
Alternatively is it possible to enter the number of times the loop
should repeat itself in a cell and have the macro read this number?

Any help will be appreciated.

-- Macro--
Sub FindCell()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending, Header:=
_
* * * * xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
* * * * DataOption1:=xlSortNormal

myValue = Range("J3").Value
For Each cell In Range("B9:B35")
If cell.Value myValue Then
* *cell.Select
* *ActiveCell.EntireRow.Select
* *Selection.Cut
* *Sheets("Dataark").Select
* *Range("A3").Select
* *Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
* *ActiveSheet.Paste

* *Set rng = Cells(Rows.Count, 2).End(xlUp)
* *rng.Select
* *ActiveCell.Copy
* *Sheets("CM").Select
* *Range("K3").Select
* *ActiveSheet.Paste
* *Selection.Font.ColorIndex = 2

* *Range("J3").Select
* *ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"

* *Exit Sub
End If
Next
End Sub

-- Macro End--

//Kasper

Nice...

Thank you very much


However I do get an error in this part:

If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then

Another question: The cell which tells the macro how many times to
repeat itself is actually H7 and consists of a count command, =COUNT
(A9:A100). Can this be integrated so I do not have to use a cell for
it?

Thank you
//Kasper

step by step?
;-)

1. out the whole expression in 1 line
If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then

2. For i =1 to Application.WorksheetFunction.Count(Range("A9:A100 "))


On 16 Gru, 12:00, Kasper wrote:
Nice...

Thank you very much

However I do get an error in this part:

If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then

Another question: The cell which tells the macro how many times to
repeat itself is actually H7 and consists of a count command, =COUNT
(A9:A100). Can this be integrated so I do not have to use a cell for
it?

Thank you
//Kasper

Okay, you can see my macro below this text. I am still having
problems, the macro only runs one loop and then stops, I must be
missing something... It doesn't report and error and functions as it
should but it doens't loop they way I hoped...
I would like it to loop until it has cut every row out with data in
Range(A9:A100)
:-)

Sub Optimer()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

myValue = Range("J3").Value
For i = 1 To Application.WorksheetFunction.Count(Range("A9:A100 "))
For Each cell In Range("B9:B35")
If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then
If cell.Value myValue Then
cell.Select
ActiveCell.EntireRow.Select
Selection.Cut
Sheets("Dataark").Select
Range("A3").Select
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Paste
Set rng = Cells(Rows.Count, 2).End(xlUp)
rng.Select
ActiveCell.Copy
Sheets("CM").Select
Range("K3").Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 2
Range("J3").Select
ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"
Exit Sub
End If
End If
Next cell
Next i
End Sub




//Kasper

You should be able to eliminate ALL selections but I can't quite figure out
what you are doing. It may be easier to just send your wb to my address
below along with a clear explanation and before/after examples. You do NOT
need to copyselect other sheetpaste.

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"Kasper" wrote in message
...
Okay, you can see my macro below this text. I am still having
problems, the macro only runs one loop and then stops, I must be
missing something... It doesn't report and error and functions as it
should but it doens't loop they way I hoped...
I would like it to loop until it has cut every row out with data in
Range(A9:A100)
:-)

Sub Optimer()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

myValue = Range("J3").Value
For i = 1 To Application.WorksheetFunction.Count(Range("A9:A100 "))
For Each cell In Range("B9:B35")
If Range("B9:B35").Rows.Count
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then
If cell.Value myValue Then
cell.Select
ActiveCell.EntireRow.Select
Selection.Cut
Sheets("Dataark").Select
Range("A3").Select
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Paste
Set rng = Cells(Rows.Count, 2).End(xlUp)
rng.Select
ActiveCell.Copy
Sheets("CM").Select
Range("K3").Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 2
Range("J3").Select
ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"
Exit Sub
End If
End If
Next cell
Next i
End Sub




//Kasper