INFINITE LOOP PROBLEM!!!

[dpalmer013]

I have an inifinite loop problem that requires urgent assistance. I've attached the spreadsheet with the data and the desired results.

Note: Actual data has been stripped due to confidentiality with a client.

Any help is much appreciated, thanks!!

[snb]

Sub M_snb()
    With Sheets("output before Macro").Columns(1)
        Set sn = Sheets("output before Macro").Columns(1).SpecialCells(2, 2).Areas
        .SpecialCells(4) = 0

        For Each ar In sn
            If ar.Rows.Count < 3 Then ar.Value = ""
        Next

        .SpecialCells(4).EntireRow.Delete
        .SpecialCells(2, 1) = ""
    End With
End Sub

[Kenneth Hobs]

As a courtesy, you should post links to where you posted the same question. For the reasons why see: http://www.excelguru.ca/node/7

cross-posted to: http://www.excelforum.com/excel-prog...g-problem.html

[dpalmer013]

Thanks Kenneth, I understand I was cross posting. My apologies for not including the link in the IP.

[dpalmer013]

Of the two loop questions, one of them has been addressed; however, I still need help on the second.

I was attempting to replicate the following VBA for Loop1 in another section of my output using Loop2 but it's not working. This loop is definitely more lengthy than the one mentioned in the initial post, but it should still work if I'm using the same logic, right??

Sub Loop1()
Dim rgFind                           As Range
   Dim sStart                      As String
   
   Set rgFind = Cells.Find(What:="EERT OUTPUT", LookIn:=xlValues, LookAt:=xlWhole, _
   SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
   
   If Not rgFind Is Nothing Then
      sStart = rgFind.Address
      Do
         With rgFind
            .Offset(4, 0).Range("A1:N2").Copy .Offset(1, 16)
            .Offset(7, 0).Range("A1:M2").Copy .Offset(1, 30)
            .Offset(10, 0).Range("A1:K2").Copy .Offset(1, 43)
            .Offset(4).Resize(9).EntireRow.Delete
         End With
         Set rgFind = Cells.FindNext(rgFind)
      Loop While rgFind.Address <> sStart
   End If
End Sub

Sub Loop2()
Dim rgFind1   As Range
Dim sStart1   As String
   
   Set rgFind1 = Cells.Find(What:="Document Number:", LookIn:=xlValues, LookAt:=xlWhole, _
   SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
   
   If Not rgFind1 Is Nothing Then
    sStart1 = rgFind1.Address
      Do
         With rgFind1
         .Offset(2, 0).Range("A1").Cut .Offset(-1, 1)
         .Offset(2, -1).Range("A1").Cut .Offset(-2, 2)
         .Offset(2, -1).Range("A1").Cut .Offset(-1, 1)
         .Offset(2, 3).Range("A1").Cut .Offset(-1, 1)
         .Offset(2, -1).Range("A1").Cut .Offset(-2, 2)
         .Offset(2, -1).Range("A1").Cut .Offset(-1, 1)
         .Offset(2, -5).Range("A1").Cut .Offset(-3, 3)
         .Offset(3, -2).Range("A1").Cut .Offset(-2, 2)
         .Offset(3, -3).Range("A1").Cut .Offset(-4, 6)
         .Offset(4, -5).Range("A1").Cut .Offset(-3, 5)
         .Offset(3, -3).Range("A1").Cut .Offset(-4, 4)
         .Offset(4, -3).Range("A1").Cut .Offset(-3, 3)
         .Offset(5, -7).Range("A1").Cut .Offset(-6, 8)
         .Offset(6, -7).Range("A1").Cut .Offset(-5, 7)
         .Offset(7, -8).Range("A1").Cut .Offset(-8, 9)
         .Offset(8, -8).Range("A1").Cut .Offset(-7, 8)
         .Offset(8, -9).Range("A1").Cut .Offset(-9, 10)
         .Offset(9, -9).Range("A1").Cut .Offset(-8, 9)
         .Offset(9, -10).Range("A1").Cut .Offset(-10, 11)
         .Offset(10, -10).Range("A1").Cut .Offset(-9, 10)
         .Offset(10, -11).Range("A1").Cut .Offset(-11, 12)
         .Offset(11, -11).Range("A1").Cut .Offset(-10, 11)
         .Offset(7, -6).Range("A1").Cut .Offset(-8, 7)
         .Offset(8, -6).Range("A1").Cut .Offset(-7, 6)
         .Offset(8, -7).Range("A1").Cut .Offset(-9, 8)
         .Offset(9, -7).Range("A1").Cut .Offset(-8, 7)
         .Offset(9, -8).Range("A1").Cut .Offset(-10, 9)
         .Offset(10, -8).Range("A1").Cut .Offset(-9, 8)
         .Offset(7, -12).Range("A1").Cut .Offset(-8, 13)
         .Offset(8, -12).Range("A1").Cut .Offset(-7, 12)
         .Offset(8, -13).Range("A1").Cut .Offset(-9, 14)
         .Offset(9, -13).Range("A1").Cut .Offset(-8, 13)
         .Offset(9, -15).Range("A1").Cut .Offset(-10, 15)
         .Offset(10, -14).Range("A1").Cut .Offset(-9, 14)
         .Offset(10, -15).Range("A1").Cut .Offset(-11, 16)
         .Offset(11, -15).Range("A1").Cut .Offset(-10, 15)
         .Offset(1).Resize(11).EntireRow.Delete
         End With
         Set rgFind1 = Cells.FindNext(rgFind1)
      Loop While rgFind1.Address <> sStart
   End If
End Sub

[dpalmer013]

I forgot to include the spreadsheet, see attached.

[SamT]

Good grief! That's horrible.

Here is your cell reference logic in English.

With rgFind1
From rgFind1 
                Go down 2 >> up 1, right1 
                Go down 2, left1 >> down 2, right 2 
                Go down 2, left1 >> up 1, right1

Find returns a single celled Range, so you are always referring to a single cell. Lose the Range("A1") reference. Just that can speed up the loop by (a ceiling of ) 25%.

Next, rewrite:

Set rgFind1 = Cells.Find(What:="Document Number:", LookIn:=xlValues, LookAt:=xlWhole, _ 
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)

To

Dim FindInColumn As Range
Set FindInColumn = Workbooks(Whatever).Range("Q:Q")  'Adjust as needed
Set rgFind1 = FindInColumn.Find(What:="Document Number:", LookIn:=xlValues, _ 
    SearchOrder:=xlByRows, SearchDirection:=xlNext)

There may be a Pattern in that operation, but the Cut cell Rows are not in order, (2,3,4,5,6,7,8,9,10,11,7,8,9,10,7,8,9,10,11.) Even the Column Offsets of each group of Row Offsets is out of order, (Offset down 2: 0,-1,-1,3,-1,-1,-5.) You cut the same address 4 times in row 2, so the Cut order is fixed, at least as it stand now. We can't help with that because we don't know the before and after States of that operation.

There may be a Pattern in the Insert operations, But I am not going to explore it given the lack of Pattern in the Cut Operations.

I suggest that you create a new Worksheet, and starting in A2 going to Z2, you fill that Row with A...Z, one letter per cell. Copy that down to about Row 14.

Name that sheet "Begin State" and copy it to another new sheet, "End State." Then run the Cut process one time on the "End State" sheet. Upload those sheets here so we can see the Pattern.

If we can analyze a Pattern, we may be able to really speed up your Macro.