Free Microsoft Excel 2013 Quick Reference

Caught in an Infinite Loop

Hi All,

I'm hoping one of you excel gurus will be able to help me with a problem I'm experiencing.

I want to update an excel chart that is based on data in a pivot table (which in turn is based on another sheet with raw data). I've written a macro that runs automatically when the chart is selected. This macro updates the pivot table on the other sheet and in doing so the chart updates itself automatically.

The problem is that at the end of the macro I've written I need to select the chart sheet again in order to leave the now updated chart visible, and doing that runs the pivot chart macro again because the macro runs automatically when the chart is updated. I need to select the chart WITHOUT running the automatic macro the second time around. Grrr! The simple code below should make this problem clear:
 Private Sub Chart_Activate()

Sheets("Pivot Table").Select

End Sub

Do we have the technology to get around this?

Incidently, the reason I have the chart arranged on a different sheet is (A) because it's neater and (B) because when I have the graph on the same sheet as the pivot table I was getting this error:

Run-time error '1004', Method 'Cells' of Object'_Global' failed

when I tried this code:

....etc etc

Any ideas are really appreciated.



Post your answer or comment

comments powered by Disqus
I have written a macro to pull and trim 3 lines of a title from an original worksheet if they were seperated during an earlier portion of the macro. The titles occur at multiple points in the page (i'm formatting a premade report). However i am stuck in an infinite loop now. any suggestions?

Sub Titles()
    Application.DisplayAlerts = False
    Dim FirstAddress As String
        With ActiveSheet.Cells
        Set c = Cells.Find(What:="page", LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
        If Not c Is Nothing Then
        FirstAddress = c.Address
        Cells(c.Row, 13).FormulaR1C1 = "=TRIM(MID(Sheet1!RC[-12],6,215))"
        Cells(c.Row + 1, 13).FormulaR1C1 = "=MID(Sheet1!RC[-12],6,215)"
        Cells(c.Row + 2, 13).FormulaR1C1 = "=MID(Sheet1!RC[-12],6,215)"
        Cells(c.Row, 1).Value = Cells(c.Row, 13).Value
        Cells(c.Row + 1, 1).Value = LTrim(Cells(c.Row + 1, 13).Value)
        Cells(c.Row + 2, 1).Value = LTrim(Cells(c.Row + 2, 13).Value)
        Range(Cells(c.Row, 1), (Cells(c.Row, 12))).Select
            With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = True
            End With
        Range(Cells(c.Row + 1, 1), (Cells(c.Row + 1, 12))).Select
            With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = True
            End With
        Range(Cells(c.Row + 2, 1), (Cells(c.Row + 2, 12))).Select
            With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = True
            End With
        Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
        End With
    Application.DisplayAlerts = True
End Sub

My code below goes into an infinite loop, with culprit line shown in bold and underline. Please help identify error in my code logic. Thank you

For ColIndex = 1 To Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToLeft)).Columns.Count 
    If Cells(4, ColIndex) = "" Then 
        Range(Cells(3, ColIndex), Cells(4, ColIndex)).Delete Shift:=xlShiftToLeft 
        [B][U]ColIndex = ColIndex - 1[/U][/B] 
    ElseIf Cells(4, ColIndex).Value = Cells(4, ColIndex + 1).Value Then 
        Range(Cells(3, ColIndex + 1), Cells(4, ColIndex + 1)).Delete Shift:=xlShiftToLeft 
        ColIndex = ColIndex - 1 
    End If 
Next ColIndex 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

I am trying to run a simple copy and paste macro when a cell changes
from 0 to 1. I have the following code for my worksheet:

Private Sub Worksheet_Calculate()

Static OldVal As Integer
If OldVal = 0 Then
If Range("E5").Value = 1 Then
Call test
End If
End If
OldVal = Range("E5").Value

End Sub

This code should just run the macro called "test" when E5 changes from
0 to 1.
My "test" macro is a module in my workbook:

Sub test()

Dim rng As Range

Set rng = Workbooks("Data").Sheets("Limits") _
.Cells(Rows.count, 1).End(xlUp)(2).Offset(3, 0)

rng.PasteSpecial xlFormats
rng.PasteSpecial xlValues

Application.CutCopyMode = False

End Sub

This should copy cells A3 to B5 and paste formats and values into the
"Limits" sheet 3 rows down from the last entry. The test macro runs
fine when I just run it manually. However, when cell E5 changes, the
code seems to run into an infinite loop. It pastes the formats but then
just seems to switch back and forth between the 'limits' and 'form'
worksheets. Anyone know why this could be? I just want the macro to
run once, then stop. Thanks for any help you can give.

I have a Dell desktop about 3 years old. Upgraded to Professional 2003 about a month ago. This week started getting an infinite loop blue error screen. It reads as follows:

"A problem has been detected and windows has been shut down to prevent damage to the computer.
Problem caused by the following file: nv4_disp

If this is the first time the screen has appeared, restart your computer, if not, follow these steps:

Device driver got stuck in an infinite loop. This usually indicates a problem with the device itself or with the device driver programming the hardware incorrectly. Please check with your hardware device vendor for any driver updates.
Technical info:
***STOP: 0x000000EA (0x82C8C298, 0x82CA6DC0, 0xF8AB5CB4, 0x00000001)

Beginning dump of physical memory.
Physical memory dump complete.
Contact your system administrator or techinical support for assistance."

Unfortunately, since this is my home computer, I don't have a system administrator to help me. What I have done is system restore to a date last week (9/21/06). This worked for about a day and then we encountered the infinite loop again. Thus, I did system restore to 9/13/06. The computer worked for a short period and moved very slow. Further, I kept getting the symantec notice that my firewall protection was not active every 30 seconds - I checked and it looked like it was running to me. After a couple hours, the infinite loop came back.

I'm so frustrated!! Can anyone provide help? I appreciate all the info I can get. MANY thanks!!


The following code loops forever and I don't know why. Please help

Sub change()


Do Until ActiveCell.Row = lETB + 1
If ActiveCell.Value  ActiveCell.Offset(-1, 0).Value Then
Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, LastCol)).Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
ActiveCell = ActiveCell.Offset(2, 0)
ActiveCell = ActiveCell.Offset(2, 0)
End If
End Sub

hello all...

i'm trying to loop through a bunch of worksheets and copy certain cells and paste it in a master sheet.

Please take a look at my code below because it keeps copying the same thing over and over and is stuck in an infinite loop.

For Each ws In ActiveWorkbook.Worksheets
    If ws.Visible = True Then

        Set rFind = Cells.Find(What:="Critical Activities / Watch List Items / and Milestones for Next 3 Months",
After:=[A1], _
                                LookIn:=xlValues, _
                                lookat:=xlPart, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False, _
        If Not rFind Is Nothing Then
        'if it's the first sheet, copy the column headers, if not skip the headers
            If = "A1 Replace Citichecking" Then
                currentRow = rFind.Row + 1
                currentRow = rFind.Row + 2
            End If
            'copy all rows until empty line, insert date and name
            'Do While Not IsEmpty(Cells(currentRow, 2))
            Do While (Cells(currentRow, 2) <> "Issues/Risks Log")
                Select Case Cells(currentRow, 2)
                    Case Is = ""
                        currentRow = currentRow + 1
                    Case Is = "Major Milestones to Program End Date Beyond Current 3 Month Cycle (Maximum 10
                        currentRow = currentRow + 1
                    Case Is = "26. Responsible Area / Owner"
                        currentRow = currentRow + 1
                    Case Else
                        Set rFindw = ActiveSheet.UsedRange.Find("Program Id", LookIn:=xlValues, lookat:=xlWhole)
                        currentRow = rFindw.Row + 1
                        strprogID = Range("K" & currentRow).Value
                        strcritical = "BCM"
                        strMileName = Range("C" & currentRow).Value
                        strMileStatus = Range("I" & currentRow).Value
                        strReason = Range("M" & currentRow).Value
                        strDescr = Range("D" & currentRow).Value
                        dtOrig = Range("G" & currentRow).Value
                        dtActual = Range("H" & currentRow).Value
                        strCommit = Range("L" & currentRow).Value
                        strMileCmmt = Range("N" & currentRow).Value
                        strRemCmmt = Range("O" & currentRow).Value
                            If rFindw Is Nothing Then
                                MsgBox "Not Found"
                                Exit Sub
                            End If
                        dest.Range("A" & cursor).Value = strprogID
                        dest.Range("B" & cursor).Value = strcritical
                        dest.Range("C" & cursor).Value = strMileName
                        dest.Range("D" & cursor).Value = strMileStatus
                        dest.Range("E" & cursor).Value = strReason
                        dest.Range("F" & cursor).Value = strDescr
                        'dest.Range("F" & cursor).EntireColumn.WrapText = True
                        dest.Range("G" & cursor).Value = dtOrig
                        dest.Range("H" & cursor).Value = dtActual
                        dest.Range("I" & cursor).Value = strCommit
                        dest.Range("J" & cursor).Value = strMileCmmt
                        dest.Range("K" & cursor).Value = strRemCmmt
                        dest.Range("L" & cursor).Value =
                        dest.Range("M" & cursor).Value = name
                        dest.Range("N" & cursor).Value = addDate
                        cursor = cursor + 1
                        currentRow = currentRow + 1
                    End Select

        End If
    End If
Next ws

'Delete columns GH in destination worksheet to fix merge issue
Columns("G:H").Delete Shift:=xlToLeft
Columns("J").Delete (xlToLeft)
Thank you.

As part of a larger program, I ask users to enter a name for the
worksheet. I want to have in built in error checking to make sure
that if the user enters a blank, just numbers, special characters, or
anything else that would cause a name in naming a worksheet that it
will ask the user for a new name until they enter one that is valid.
This is the section of code that causes problems:

Public Function CheckSheet(newSheetName As String) As String
Dim ws As Worksheet

'Makes sure that the name is a valid name in Excel (not numeric,
special characters, or blank)
On Error GoTo ErrHandler:
Set Sheets(ws).Name = newSheetName

CheckSheet = newSheetName

MsgBox "Please enter a valid name.", vbInformation
newSheetName = InputBox("What would you like to name the new
week?", "Week Name")
On Error GoTo 0
End Function

I am not that familiar with using On Error and have looked at pretty
much all the how to's on the internet, but I can't figure out my
problem. I have also tried using it a number of other ways including
a while loop that tries to make use of the IsError function, but
everything I try gives me either an error message or an infinite

I think I am getting a type mismatch error when I try to set the sheet
name to the user defined (newSheetName) variable, but I'm not sure

Any help is greatly appreciated!

What a waste of a day. I hope somebody smarter than me can help out with this one!

I am trying to get the following script to work

Private Sub Worksheet_Change(ByVal Target As Range)
Set namRng = ActiveWorkbook.Names("guestDetailsNamesList")
    If Intersect(Target, Range(namRng)) Is Nothing Then
        Exit Sub
    For Each r In Range(namRng)
        a = r.Address
        r.Value = Evaluate("Trim(" & a & ")")
    End If
End Sub
The problem is that when I apply the new value to variable "r" it resets the For Each statement and the script falls into an infinite loop.

Can anybody explain why?


I have a problem. I have a findnext search function that I use to update a source worksheet in Excel. The problem is that it does an infinite looping because to stop the looping it must meet a condition which deactivate the do while looping. But if it does not find this condition, it will always loop. Is there a way to say after FindNext had done a first and complete checkup to have a variable which says stop?
I've posted the code at the end of this message. If anyone needs any more details, tell me.


With RangeData 
    Set UERow = .Find(IDUform, LookIn:=xlValues, lookat:=xlWhole) 
    If Not UERow Is Nothing Then 'if a match found
        find_rw = UERow.Row 
    Else 'if not
        MsgBox "IDU does not exist." 
    End If 
    Do While BoolRow = False 
        If Worksheets("PI").Range("B" & find_rw).Value = _ 
        Worksheets("Formulaire").Range("A" & L).Value Then 
             'If we got it, we exit the looping with the boolean value to True.
            BoolRow = True 
             'We continue
            Set UERow = .FindNext(UERow) 
            find_rw = UERow.Row 
        End If 
End With 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


More problems....

I'm running a routine everytime a change is made on a worksheet via code similiar to this:

    Cells(1,1).Value= "99" 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This routine actually puts a value onto the worksheet, which is effectively causing another change, thus running the routine again. Consequently, the routine gets lost in an infinite loop.

Is there anyway of writing code that will stop the routine from repeating itself?

many thanks

Hi all,

I wrote a macro to insert the current date in a date column (G) when any value in that row is changed... the problem is, if you insert a new row (which wouldn't be done on a regular basis... but may be done at some point), it throws itself into an infinite loop, and fills the whole sheet with dates. Any ideas why this might be?



Private Sub Worksheet_Change(ByVal Target As Range)
 Dim currentcell As String
 Dim row As String
 Dim col As String
 Dim dateCell As String
 Dim thisCell As Range
 currentcell = Target.Address(False, False)
 row = Mid(currentcell, 2)
 col = Left(currentcell, 1)
 If row > 1 Then
  dateCell = "G" & row
  Set thisCell = Range(dateCell)
  thisCell.Value = Now()
 End If
End Sub

A few days ago, Tom Ogilvy provided a macro for me on
this newsgroup that enabled someone to search an entire
workbook in Excel 97/2000, not just the current sheet.
I'm posting a follow up question as a new thread as Tom
is probably not still checking the original thread.

The macro Tom supplied (pasted below) creates an infinite
loop if (I think) you give an empty string in response to
the input box. It just keeps putting up the message "Hit
key to continue" and you can't break out of it.

Would it be possible for anyone (or Tom if he's reading
this) to correct the macro so an infinite loop does not
occur, please?

Steve Wylie

Sub FindAll()
Dim sh As Worksheet
Dim rng As Range
Dim sStr As String
sStr = InputBox("Enter search text")
If sStr = "" Then
MsgBox "You hit cancel"
End If
For Each sh In ActiveWorkbook.Worksheets
Set rng = sh.Cells.Find(What:=sStr, _
After:=sh.Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
If Not rng Is Nothing Then
firstAddress = rng.Address
If Not rng Is Nothing Then
Application.Goto rng, True
MsgBox "Hit key to continue"
End If
Set rng = sh.Cells.FindNext(rng)
Loop Until rng.Address = firstAddress
End If
End Sub

I am getting an infinite loop when I run this code and today's date
isn't found. I'd like it to do nothing if it's not found. How would I
do that ?

For Each rCell In Selection
If rCell.Value = Date Then Range(rCell.Address).Offset(1, 0).Activate

Next rCell

Through my own fault i created an infinite loop with a message box getting called repeatedly. I want to crash out but the escape key wasnt working and the stop button was greyed out. In the end I resorted to task manager and lost an hours worth of work.

Obviously the lesson is to save before running, and code better. But is there a way of stopping execution if I am in this situation again?

There are two sheets in the workbook. First sheet has certain values in a number of rows in a column. The second sheet also has values in each row in repeating patterns in a column. Like this:

   Sheet1          Sheet2
        A                   A
1  AAAA          gre1111assdf
2  BBBB          gfd2222dfhh
3  CCCC         jytjtu3333dgrt
4  DDDD         yufg4444fbth
5  EEEE          sdfs5555gfd
The macro is supposed to go through each row in Sheet2 per each row in the first sheet; assign a certain value to a variable when any given row in Sheet2 includes some other certain values; compare this variable's value to the row value in Sheet1 and quit once this process has been repeated for 4 rows in Sheet1:

Sub GetWpFromXMLs()
Application.ScreenUpdating = False

    Dim sRange As Range '// "source" Range ie. Sheet2
    Dim dRange As Range '// "destination" Range ie. Sheet1

    dRow = 0 '// "destination" Row  ie. Sheet1
    dCol = 2 '// "destination" Column ie. Sheet1
    sRow = 0 '// "source" Row ie. Sheet2
    Set dRange = ActiveSheet.Range("A1").Offset(dRow, 0)
    Set sRange = Sheets("Sheet2").Range("A1").Offset(sRow, 0)

    If InStr(1, sRange, "1111") > 0 Then critName = "AAAA" '// "AAAA" is the value of A1 in
    If InStr(1, sRange, "2222") > 0 Then critName = "BBBB" '// "BBBB" is the value of A2 in
    If InStr(1, sRange, "3333") > 0 Then critName = "CCCC" '// "CCCC" is the value of A3 in
    If InStr(1, sRange, "4444") > 0 Then critName = "DDDD" '// "DDDD" is the value of A4 in
    If InStr(1, sRange, "5555") > 0 Then critName = "EEEE" '// "EEEE" is the value of A5 in

    If dRange.Value = critName Then '// if the value extracted from the current Row in Sheet2 (sRange) matches the value of
the current row in Sheet1 (dRange)
        MsgBox critName '// show what value was extracted
        dRow = dRow + 1 '// since current row in Sheet1 was taken care of, move onto the next row for the next loop
        sRow = 0 '// start over from the first row in Sheet2 in the next loop
        sRow = sRow + 1 '// since the current row in Sheet2 didn't match the current row in Sheet1, move onto the next row in
    End If

    Loop Until dRow = 4 '// stop once first 3 rows in Sheet1 are taken care of

Application.ScreenUpdating = True
End Sub
This is supposed to stop once the match for the 3rd row in Sheet1 is found in Sheet2 but it only happens for the 1st row in Sheet1 and then goes into infinite loop.

I am very confused. Supposed to be that once a match for the first row of Sheet1 is made, dRow is incremented by 1 and thus looking for a match in for the second row of Sheet1 while sRow is reset to 0 so it starts from the first row of Sheet2 so as not to miss any rows. What is wrong here?


I was wondering if there was anyway to create a macro that would
automatically open with a .cvs file and produce a chart of the data. I
am not familiar with VBA and though I did find a similar macro on this
group (posted 10/20/2003), it doesn't open automatically and for some
reason gets caught up in an infinite loop. Another option I'm
interested in would be a button on the toolbar in excel that when
clicked could automatically create a chart. Also, is there any easy
way to have it chart some columns but not others? Thanks for your time
and assistance! Any constructive ideas would be sincerely appreciated!

Hi everybody!

tl;dr-version: I'm trying to make lots of small queries to a small database, but the infinite loop takes 10+ seconds to execute every other time in the loop. Help, code below.

Long version: I need to make lots of small queries to a very small database (under 100 rows) and write values to cells. I have set up a local database and used the code below to test the idea. The code just runs the same query in an infinite loop, writes down the CategoryId and selects a new cell beneath the current cell. But I'm having performance issues already.

The weird thing is that the query runs VERY SLOW, it takes around 10 seconds for the myCmd.Execute -line to run, but only on every other time the line is run! Every other time the loop runs instantly eg. the first time in the loop takes 10s, second 0s, third 10s again, fourth 0s and so on. And the code runs always the same query!

Furthermore the query always returns 2 rows. If I change the SQL-query so that it returns only 1 row, the code executes instantly, even if it would query for different things. The code is blazing fast always, if the query would return only 1 row.

So the question is, is there something wrong with the code? Or am I using the Connection, Command and Recordset objects the wrong way? Because getting 2 rows from a local database shouldn't take 10+ seconds, especially when getting 1 row happens instantly.

I'm quite baffled, to be honest, why the code acts this way.

Thanks for your time in advance!

    Dim myRecordset As Recordset 
    Dim myConn As Connection 
    Dim myCmd As Command 
    sqlCommand = "SELECT CategoryId, CategoryName FROM H_BudgetEntries WHERE CategoryId=1 Or CategoryId=2" 
    Set myConn = New Connection 
    With myConn 
        .ConnectionString = "Provider=SQLOLEDB;Initial Catalog=TESTDB;Data Source=.;Trusted_connection=yes;" 
    End With 
    Set myCmd = New Command 
    myCmd.CommandText = sqlCommand 
    Set myCmd.ActiveConnection = myConn 
    Do While True ' Infinite loop
        Set myRecordset = myCmd.Execute ' This line of code takes almost 10 seconds to complete, but only on every other time
it is run
        Selection.Value = myRecordset.Fields(1) 
        Selection.Offset(1, 0).Select 'BREAKPOINT HERE
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

I have this pivot table that I would like to auto run a macro when the user refreshes the pivot.

Problem is a get an infinite loop.

Sheet code:

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
    Call UpdatePivot
End Sub
Sub Code

Sub UpdatePivot()
Dim LastRow As Long
LastRow = Range("master!A" & Rows.Count).End(xlUp).Row
   ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
       "master!R1C1:R" & LastRow & "C10"
    ActiveWorkbook.ShowPivotTableFieldList = True
    Application.WindowState = xlMinimized
End Sub
Everytime I hit the refresh button it calls the code, but after the line I highlighted, it starts over and runs again. I just want the code to run 1 time once the user hits the refresh button.



I am working on a VBA macro, using the following code:

    With wsSheet.Range("A:A")
        ReDim MyArray(1 To .Rows.Count, 1 To .Columns.Count)
        MyArray = wsSheet.Range("A:A")
        For i= 1 To .Rows.Count
        For j= 1 To .Columns.Count
            wsSheet.Cells(i, j+ .Offset(0, 3).Column) = MyArray(i, j)
    Next: Next
I want to select alla values in column A, but when I specify the range as "A:A" the code results in an infinite loop! How can I come around this?

Hi Everyone,

I am trying to write some code that summarises certain results from sheets in a workbook, depending on certain conditions, and outputs them to a text file. The example below shows the sort of thing I am tryint to achieve. I want to look through the 'Status' list, and output the details directly adjacent on the right and left when the status is "Hot".

The problem I seem to be having is that I cannot pick up the details either side of the Status column. I am using For each ... in selection... to skip through the Status list, and ...offset(x,y) to select cells containing the details I want to retrieve.

The code below neither picks up the details in the 1st and third columns when the status is "Hot", nor does it stop correctly at the end of the column, getting caught up in an infinite loop. I would be very grateful for any suggestions to achieve the desired result.

Many thanks,


Identifier ---Status ---Details
1 ----------hot -----text here
2 ----------hot -----more text here
3 ----------cold -----more text here
4 ----------cold -----even more text here
5 ----------hot -----even more text here
6 ----------hot -----less text here
7 ----------cold -----less text here

Sub open_text_demo()
Dim sel_range As Variant, n As Integer, m As Integer
Dim tab_range As Variant, tabrange As String, selrange As String
tab_range = Array("Tab1", "Tab2")
sel_range = Array("status1", "status2")

'Creating the file
Open "C:Log_filesdailylog.txt" For Output As #1

'first For statement
    For n = 0 To 1
        tabrange = tab_range(n)

'second For statement
        For m = 0 To 1
            selrange = sel_range(m)
            On Error GoTo nextinline:
            For Each Line In Selection
            Status = Line.Value
            If Status = "Hot" Then
                Identifier = ActiveCell.Offset(0, -1).Value
                Details = ActiveCell.Offset(0, 1).Value
        'printing to text file
            Print #1, "Identifier: ", Identifier
            Print #1, "Details: ", Details
            Print #1, " "
            Print #1, " "
            'ElseIf Status = " " Then
                'GoTo for1:
            'End If
nextinline:            Resume skip
        'incrementing loop-through counter
        Next m
    Next n
Close #1
End Sub

Hi I have the following in my sheet code and it seems to be getting locked into an endless loop:

Private Sub Worksheet_Change(ByVal Target As Range)
End Sub

Copy Format and Format2 are as follows:

Sub CopyFormat()
Dim i As Long, CopyRow As Long

'loop through all of the rows listed in the myRow range
For i = 17 To 77
Select Case Cells(i, "DP")
Case Is = 1
CopyRow = 16
Case Is = 2
CopyRow = 17
Case Is = 3
CopyRow = 18
Case Is = 4
CopyRow = 19
Case Else
CopyRow = 0
End Select
If CopyRow > 0 Then

'copy the cell in DS
Cells(CopyRow, "DS").Copy

'paste the format to G:J of the same row
'being checked in column DP
Cells(i, "G").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

End If

Next i

End Sub

Sub CopyFormat2()
Dim i As Long, CopyRow As Long

'loop through all of the rows listed in the myRow range
For i = 17 To 77
Select Case Cells(i, "DQ")
Case Is = 1
CopyRow = 16
Case Is = 2
CopyRow = 17
Case Else
CopyRow = 0
End Select
If CopyRow > 0 Then

'copy the cell in DX
Cells(CopyRow, "DX").Copy

'paste the format to O of the same row
'being checked in column DQ
Cells(i, "O").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

End If

Next i

End Sub

These macros work fine but not in the Worksheet_Change sheet code.

I am pretty sure it because each time the macro makes a change, it gets fired again and then get caught in an endless loop.

How do I write the sheet code so it only goes throught the loop one time and stops.

Thanks for any help...Dean


Very novice VBA user here. Apologies for the clumsy name of this thread, I'm not quite sure how to explain what I'm experiencing.

I am attempting to implement a solution at work, whereby a summary sheet ('TravelTimeCalculator') is created that can call up all hours that need to be paid for a given staff member in a given month that is not included in a 'job', such as travel time and wait time between jobs. The spreadsheet has multiple sheets that need to be searched to pull this data.

Essentially, on this summary sheet I have a cell with predefined choices for the staff members name (B2) and another where the month can be selected (B3). The macro then searches all sheets for a row that has that staff members name, the selected month and is designated as 'travel' or 'approved wait time'. Where it finds such a row it is copied onto the summary sheet.

This much works fine with the following solution;
Sub Time()
' Time Macro
' Copies all lines to Travel Time Calculator that meet the selected criteria in sheet 'TravelTimeCalculator'
    Dim WkSht As Worksheet
    Dim r As Integer
        For Each WkSht In ThisWorkbook.Worksheets
        If WkSht.Name <> "TravelTimeCalculator" Then
        For r = 1 To 3000
        'This will check the first 3000 rows of each sheet - Increase if needed
            If WkSht.Range("B" & r).Value =
Sheets("TravelTimeCalculator").Range("B2").Value _
            And WkSht.Range("I" & r).Value =
Sheets("TravelTimeCalculator").Range("B3").Value _
            And (WkSht.Range("K" & r).Value = "Travel" Or WkSht.Range("K" & r).Value =
"Approved wait time") Then
                    WkSht.Rows(r & ":" & r).Copy
            End If
    Next r
    End If

    Next WkSht

End Sub
However, I would like it to be able to tell the user if no records match the set criteria, so we can differentiate between a true absence of match and a broken macro

To do this I attempted the following code;

Sub Time()
' Time Macro
' Copies all lines to Travel Time Calculator that meet the selected criteria in sheet 'TravelTimeCalculator'
    Dim WkSht As Worksheet
    Dim r As Integer
        For Each WkSht In ThisWorkbook.Worksheets
        If WkSht.Name <> "TravelTimeCalculator" Then
        For r = 1 To 3000
        'This will check the first 3000 rows of each sheet - Increase if needed
            If WkSht.Range("B" & r).Value =
Sheets("TravelTimeCalculator").Range("B2").Value _
            And WkSht.Range("I" & r).Value =
Sheets("TravelTimeCalculator").Range("B3").Value _
            And (WkSht.Range("K" & r).Value = "Travel" Or WkSht.Range("K" & r).Value =
"Approved wait time") Then
                    WkSht.Rows(r & ":" & r).Copy
            Else: MsgBox "No valid entries"
            End If
    Next r
    End If

    Next WkSht

End Sub
This appears to work, to a point. If I put in a criteria I know cannot be matched, I get the appropriate pop up. However, on clicking 'okay', the pop triggers again immediately and appears to be stuck in an infinite loop, not allowing the user to do anything else. To get out of this, I have to force close excel.

I thought it might be that it was stuck looping between the worksheets. However, adding an 'End if' after 'Next WkSht' gives the error 'End if without block if'.

Does anyone have any ideas of how I could stop the MsgBox pop up loop, or any other way to signify that there are no rows matching the given criteria in the workbook?

Please do not hesitate to ask for additional explanation if I am not clear. I know am not at all knowledgeable about appropriate terms

Thank you very much for any assistance you can provide,


In order to get a better understanding of the CurrentRegion property
I wrote the following code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox Target.CurrentRegion.Address
End Sub

Now if A1 (say) is part of a block of non-blank cells and I select A1
then *three* times I end up having to dismiss the message box.
Apparantly, the CurrentRegion property, when it returns more than 1
cell, triggers two selection change events. At least it doesn't hang up
in an infinite loop.

To test this hypothesis I wrote

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox Target.Address
End Sub

Sub test()
Dim R As Range
Set R = Range("A1").CurrentRegion
End Sub

The act of running test() triggers two selection changes. In my
experiment, A1:B12 is a range of contiguous non-blank cells. I start by
selecting (say) D10 and then run test(). Twice a message box with
$A$1:$B$12 appears, after which D10 is still selected. Wierd. I would
find the bug more understandable if the second message box was $D$10.
Application.EnableEvents provides a work-around.

Has anyone else encountered this bug? Are there any other phantom
events I should be aware of?

-John Coleman


I am running a private sub in a worksheet (pasted below)
In this sub it highlights the colorindex of cells. I had to do this because 2003 only allows 3 conditional formats. This part works fine, but when I try to add and accumulators it gets stuck in an infinte loop. For some reason the for each will not break with any or all of the 4 accumulators. As soon as I take them out it works fine. Any help would be greatly appreciated

Thank You
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim BSA1 As Variant
 Dim BSA2L1 As Variant
 Dim BSA2L2 As Variant
 Set BSA1 = Range("E6:E1500")
 Set BSA2L1 = Range("AB6:AB1500")
 Set BSA2L2 = Range("AX6:AX1500")
 Dim Cell As Variant
 Dim CellBSA1CK As Variant
 Dim CellBSA1King As Variant
 Dim CellBSA1Queen As Variant
 Dim CellBSA1Dbl As Variant
 Set CellBSA1CK = Range("M1")
 Set CellBSA1King = Range("M2")
 Set CellBSA1Queen = Range("M3")
 Set CellBSA1Dbl = Range("M4")
 CellBSA1CK.Value = 0
 CellBSA1King.Value = 0
 CellBSA1Queen.Value = 0
 CellBSA1Dbl.Value = 0
   For Each Cell In BSA1
        If Cell.Value > 138 And Cell.Value < 148 Then
            Cell.Interior.ColorIndex = 6
            CellBSA1Dbl.Value = CellBSA1Dbl.Value + 1      <----- Accumulator 1
        End If
        If Cell.Value > 156 And Cell.Value < 166 Then
            Cell.Interior.ColorIndex = 5
            CellBSA1Queen.Value = CellBSA1Queen.Value + 1 <----- Accumulator 2
        End If
        If Cell.Value > 196 And Cell.Value < 206 Then
            Cell.Interior.ColorIndex = 4
            CellBSA1King.Value = CellBSA1King.Value + 1 <----- Accumulator 3
        End If
        If Cell.Value > 217 And Cell.Value < 227 Then
            Cell.Interior.ColorIndex = 46
            CellBSA1CK.Value = CellBSA1CK.Value + 1 <----- Accumulator 4
        End If
        If Cell.Value < 138 Or Cell.Value >= 148 And Cell.Value <= 156 Or Cell.Value >= 166 And Cell.Value <=
196 Or Cell.Value >= 206 And Cell.Value <= 217 Or Cell.Value >= 227 Then
            Cell.Interior.ColorIndex = 0
        End If

End Sub

No luck finding an answer? You could always try Google.