Looping through Range...Slow

C

Craig M

Hi there.... I know that looping through a range is not the fastest way to
do it. But looking at different examples I can't quite figure out how to do
it in my sistuation.

Currently I am looping through a range(C1:C100), if the value is 1 then
corrisponding row in Range(A1:A100) the text is changed to RED, if the value
is 2 then corrisponding row in Range(A1:A100) the text is changed to Blue,
if the value is 3 then corrisponding row in Range(A1:A100) the text is
changed to Black and Bold, if the value is 4 then nothing. I have this
working in a Userform under a spreadsheet control. It works fine except it
runs very slow. I've tried adding Application.ScreenUpdating=False... which
didn't help

Is there a better way to run this?

Thanks Craig
 
G

Gary Keramidas

shouldn't be slow looping a hundred cells, can you post the relevant code?
 
W

ward376

Looping through only a hundred cells should go pretty quickly, but if
your actual dataset is much larger than your example, using filters
will make a noticeable difference.

Try something like this...

Sub color()
With Cells(1, 1)
.AutoFilter 'turns on filter
.AutoFilter Field:=3, Criteria1:=1
.CurrentRegion.Offset(1, 0).Columns(1).SpecialCells _
(xlCellTypeVisible).Font.ColorIndex = 3 'red
.AutoFilter Field:=3, Criteria1:=2
.CurrentRegion.Offset(1, 0).Columns(1).SpecialCells _
(xlCellTypeVisible).Font.ColorIndex = 5 'blue
.AutoFilter Field:=3, Criteria1:=3
.CurrentRegion.Offset(1, 0).Columns(1).SpecialCells _
(xlCellTypeVisible).Font.Bold = True 'bold, I assumed the
text was already black
.AutoFilter 'turns off filter
End With
End Sub
 
C

Craig M

I guess there is more happening here.... I was just wondering if I can make
it run a little faster! On a slower machine....


Private Sub OptionButton1_Change()
Dim ssConstants
If OptionButton1.Value = True Then
Sheet1.Range("P1").Value = 5
Spreadsheet1.ActiveSheet.Unprotect
Call border_reset
Set ssConstants = Spreadsheet1.Constants
Spreadsheet1.Worksheets("Sheet1").Range("B2:B4").BorderAround ,
ssConstants.xlMedium, 3
Spreadsheet1.Worksheets("Sheet1").Range("B6:B44").BorderAround ,
ssConstants.xlMedium, 3
Spreadsheet1.Worksheets("Sheet1").Range("B46:B47").BorderAround ,
ssConstants.xlMedium, 3
Spreadsheet1.Worksheets("Sheet1").Range("B49").BorderAround ,
ssConstants.xlMedium, 3
Call diff_reset
Call Chk_Concern
Spreadsheet1.ActiveSheet.Protect
End If
End Sub

Public Sub border_reset()
Dim ssConstants
Set ssConstants = Spreadsheet1.Constants
Spreadsheet1.Worksheets("Sheet1").Range("D2:D4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F2:F4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H2:H4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J2:J4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B2:B4").BorderAround ,
ssConstants.xlHairline, 1

Spreadsheet1.Worksheets("Sheet1").Range("D6:D44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F6:F44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H6:H44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J6:J44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B6:B44").BorderAround ,
ssConstants.xlHairline, 1

Spreadsheet1.Worksheets("Sheet1").Range("D46:D47").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F46:F47").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H46:H47").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J46:J47").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B46:B47").BorderAround ,
ssConstants.xlHairline, 1

Spreadsheet1.Worksheets("Sheet1").Range("D49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B49").BorderAround ,
ssConstants.xlHairline, 1

End Sub

Public Sub diff_reset()
For i = 6 To 49
Spreadsheet1.Cells(i, 16).Value = Sheet1.Cells(i, 16).Value
If Spreadsheet1.Cells(i, 16).Value < 0 Then
Spreadsheet1.Cells(i, 16).Font.Color = vbRed
Spreadsheet1.Cells(i, 16).Font.Bold = True
ElseIf Spreadsheet1.Cells(i, 16).Value > 0 Then
Spreadsheet1.Cells(i, 16).Font.Color = vbBlue
Spreadsheet1.Cells(i, 16).Font.Bold = True
Else
Spreadsheet1.Cells(i, 16).Font.Color = vbBlack
End If
Next i
End Sub

Public Sub Chk_Concern()
For rRow = 6 To 47
If Spreadsheet1.Cells(rRow, 21).Value = 0 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlack
Spreadsheet1.Cells(rRow, 14).Font.Bold = True
ElseIf Spreadsheet1.Cells(rRow, 21).Value = 1 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlue
Spreadsheet1.Cells(rRow, 14).Font.Bold = True
ElseIf Spreadsheet1.Cells(rRow, 21).Value = 2 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbRed
Spreadsheet1.Cells(rRow, 14).Font.Bold = True
ElseIf Spreadsheet1.Cells(rRow, 21).Value = 3 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlack
Spreadsheet1.Cells(rRow, 14).Font.Bold = False
Else
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlack
Spreadsheet1.Cells(rRow, 14).Font.Bold = False
End If
Next rRow
End Sub
 
G

GKeramidas

would something like this work, i just adapted the last part of it so you
could try it.

Sub test2()
For Each cell In Range("U6:U47")

Select Case cell.Value
Case Is = 0
cell.Offset(0, -7).Font.Color = vbBlack
cell.Offset(0, -7).Font.Bold = True
Case Is = 1
cell.Offset(0, -7).Font.Color = vbBlue
cell.Offset(0, -7).Font.Bold = True
Case Is = 2
cell.Offset(0, -7).Font.Color = vbRed
cell.Offset(0, -7).Font.Bold = True
Case Is = 3
cell.Offset(0, -7).Font.Color = vbBlack
cell.Offset(0, -7).Font.Bold = False
Case Else
cell.Offset(0, -7).Font.Color = vbBlack
cell.Offset(0, -7).Font.Bold = False
End Select
Next
End Sub
 
N

NickHK

You can work on multiple ranges simultaneously and also cut down on the
number of objects (the number of "."s ) that has to resolved each time,
either by using the "With" keyword" of setting an object variable to the
object(s) that you are manipulating
For example:

Dim WorkRange As Range

If OptionButton1.Value Then
Sheet1.Range("P1").Value = 5
With Spreadsheet1
.ActiveSheet.Unprotect
Call border_reset
Set ssConstants = .Constants

With .Worksheets("Sheet1")
Set WorkRange = Union(.Range("B2:B4"), .Range("B6:B44"),
..Range("B46:B47"), .Range("B49"))
End With
WorkRange.BorderAround , ssConstants.xlMedium, 3

Call diff_reset
Call Chk_Concern
.ActiveSheet.Protect
End With
End If

Your other routuines would also benefit from these chnages.

NickHK
 
C

Craig M

I guess there is more happening here.... I was just wondering if I can make
it run a little faster! On a slower machine....


Private Sub OptionButton1_Change()
Dim ssConstants
If OptionButton1.Value = True Then
Sheet1.Range("P1").Value = 5
Spreadsheet1.ActiveSheet.Unprotect
Call border_reset
Set ssConstants = Spreadsheet1.Constants
Spreadsheet1.Worksheets("Sheet1").Range("B2:B4").BorderAround ,
ssConstants.xlMedium, 3
Spreadsheet1.Worksheets("Sheet1").Range("B6:B44").BorderAround
,ssConstants.xlMedium, 3
Spreadsheet1.Worksheets("Sheet1").Range("B46:B47").BorderAround
,ssConstants.xlMedium, 3
Spreadsheet1.Worksheets("Sheet1").Range("B49").BorderAround ,
ssConstants.xlMedium, 3
Call diff_reset
Call Chk_Concern
Spreadsheet1.ActiveSheet.Protect
End If
End Sub

Public Sub border_reset()
Dim ssConstants
Set ssConstants = Spreadsheet1.Constants
Spreadsheet1.Worksheets("Sheet1").Range("D2:D4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F2:F4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H2:H4").BorderAround
,ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J2:J4").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B2:B4").BorderAround
,ssConstants.xlHairline, 1

Spreadsheet1.Worksheets("Sheet1").Range("D6:D44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F6:F44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H6:H44").BorderAround
,ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J6:J44").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B6:B44").BorderAround
,ssConstants.xlHairline, 1

Spreadsheet1.Worksheets("Sheet1").Range("D46:D47").BorderAround
,ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F46:F47").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H46:H47").BorderAround
,ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J46:J47").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B46:B47").BorderAround
,ssConstants.xlHairline, 1

Spreadsheet1.Worksheets("Sheet1").Range("D49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("F49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("H49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("J49").BorderAround ,
ssConstants.xlHairline, 1
Spreadsheet1.Worksheets("Sheet1").Range("B49").BorderAround ,
ssConstants.xlHairline, 1

End Sub

Public Sub diff_reset()
For i = 6 To 49
Spreadsheet1.Cells(i, 16).Value = Sheet1.Cells(i, 16).Value
If Spreadsheet1.Cells(i, 16).Value < 0 Then
Spreadsheet1.Cells(i, 16).Font.Color = vbRed
Spreadsheet1.Cells(i, 16).Font.Bold = True
ElseIf Spreadsheet1.Cells(i, 16).Value > 0 Then
Spreadsheet1.Cells(i, 16).Font.Color = vbBlue
Spreadsheet1.Cells(i, 16).Font.Bold = True
Else
Spreadsheet1.Cells(i, 16).Font.Color = vbBlack
End If
Next i
End Sub

Public Sub Chk_Concern()
For rRow = 6 To 47
If Spreadsheet1.Cells(rRow, 21).Value = 0 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlack
Spreadsheet1.Cells(rRow, 14).Font.Bold = True
ElseIf Spreadsheet1.Cells(rRow, 21).Value = 1 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlue
Spreadsheet1.Cells(rRow, 14).Font.Bold = True
ElseIf Spreadsheet1.Cells(rRow, 21).Value = 2 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbRed
Spreadsheet1.Cells(rRow, 14).Font.Bold = True
ElseIf Spreadsheet1.Cells(rRow, 21).Value = 3 Then
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlack
Spreadsheet1.Cells(rRow, 14).Font.Bold = False
Else
Spreadsheet1.Cells(rRow, 14).Font.Color = vbBlack
Spreadsheet1.Cells(rRow, 14).Font.Bold = False
End If
Next rRow
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Looping through permutations 7
Search & insert 3
EXCEL VBA RANGE Question 9
Turn a range of cells into 'read only' 7
Variable Range Copy... 13
Delete contents of cells in a range based on value of a cell 2
Looping through a range & getting values 2
loop through every other and 3rd cell in range 2

Top