VB: Convert rectangular clusters of # within field: FindNext, Find

[Benjamin Fortunato]

I am having trouble with a script that keeps hanging and I don't know how to
debug it. Its supposed to go through and search for a rectangular array of
numbers ," 2", within a field of 0, and convert the end columns of that
rectangular array to 0 and the bottom left and right values to 1. See the
example. The line that the debugger is pointing to is the the following:
iValue = i.Offset(rowOffset:=0, columnOffset:=1).Value

Its in the nested do loop that cycles through each row. The other do loop
cycles through the rows, and the outer most loop cycles through the entire
worksheet.

This array
0 0 0 0 0
0 2 2 2 0
0 2 2 2 0
0 0 0 0 0

should become:

0 0 0 0 0
0 0 2 0 0
0 1 2 1 0
0 0 0 0 0


The Code:

Public Sub Regen()
Dim AllCells As Range
Dim CellArray As Variant
Dim bolLoop As Boolean
Dim intRowCount As Integer
Dim RectangleRange As Range
Dim ifirst As Range
Dim iLast As Range
Dim iFirstAbs As Range
Dim i As Range
Dim iValue As Integer



Set AllCells = Worksheets(1).Range("a1:m25")
Set AllCells2 = Worksheets(2).Range("a1:m25")
With AllCells
.Value = "0"
For Each c In AllCells
If c.Interior.Color = RGB(128, 128, 128) Then
c.Value = "2"
End If
Next
End With

CellArray = Range("a1:m25").Value
AllCells2.Value = CellArray
AllCells.Value = ""

Worksheets(2).Activate

bolLoop = True
intRowCount = 0
Set i = AllCells2.Find(2, After:=Range("a1"), LookIn:=xlValues,
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
SearchFormat:=False)
Set iFirstAbs = i
Set ifirst = i

'loops through the entire range untill the counter is set to the first
found value
Do
'loops through untill it find a set of adjacent values, ie a
rectangle
Do While bolLoop = True
iValue = i.Offset(rowOffset:=0, columnOffset:=1).Value

'loops through one individual row of the rectangle
Do While iValue = 2
i = AllCells2.FindNext(i)
iValue = i.Offset(rowOffset:=0, columnOffset:=1).Value
Loop

intRowCount = intRowCount + 1
iNext = ifirst.Offset(rowOffset:=intRowCount)

If iNext = Not 2 Then
bolLoop = False
i = iLast
Call FillRectangleNum(ifirst, iLast)
Exit Do

ElseIf iNext = 2 Then
i = iNext
iValue = 2
End If
Loop
'add code to start search from ilast
ifirst = AllCells2.Find(2, After:=Range(iLast), LookIn:=xlValues,
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
SearchFormat:=False)
Loop Until iFirstAbs = i

End Sub


Public Function FillRectangleNum(ifirst As Range, iLast As Range)
Worksheets(1).Activate
Dim RectangleRange As Range
Dim FirstClmn As Range
Dim LastClmn As Range
Dim LastRow As Range
Dim btmLeft As Range
Dim btmRight As Range
Set RectangleRange = Range(ifirst, iLast)
RectangleRange.Value = 2
Set FirstClmn = RectangleRange.Columns(1)
FirstClmn.Value = 0
Set LastClmn = RectangleRange.Columns(RectangleRange.Columns.Count)
LastClmn.Value = 0
Set LastRow = RectangleRange.Rows(RectangleRange.Rows.Count)
Set btmLeft = Application.Intersect(LastRow, FirstClmn)
btmLeft.Value = 1
Set btmRight = Application.Intersect(LastRow, LastClmn)
btmRight.Value = 1
End Function

 

[Rick Rothstein]

A little more information please. The cells you looking for... do they start
of "gray" in color? It looks like you search for RGB(128,128,128) and fill
them with the number 2 which you then look like you are searching for. If
they start off as gray in color, we *may* be able to search for that
directly (and more easily than a looking for a rectangle of 2's). Tell us
more about your set up (gray cells, other cell colors, color of surrounding
cells, initial values, etc.) and let's see if we can find an different way
to do what you want.