Prev: mouse pointer to be focused on userform command button upon opening
Next: Data Connection: Access Query to Excel How to get rid of heade
From: Benjamin Fortunato Benjamin on 26 Feb 2010 11:21
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

 | 
Pages: 1
Prev: mouse pointer to be focused on userform command button upon opening
Next: Data Connection: Access Query to Excel How to get rid of heade