CODEWITHSUNDEEP
vbaexcel
Matt Taylor
Matt Taylor

Reputation: 671

search cell for string then run macro if string is found

Right now my macro runs but doesn't get all the numbers. If it ran once on #2 then the next #2 gets skipped. How can i prevent this. I want all #'s to get processed.

Example:
HI (2 SHEETS)
OK (3 SHEETS)
BYE (2 SHEETS)

should be:
HI (2 SHEETS)
HI (2 SHEETS)
OK (3 SHEETS)
OK (3 SHEETS)
OK (3 SHEETS)
BYE (2 SHEETS)
BYE (2 SHEETS)

This is what i have so far.

OLD 

Sub ExpandRows()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim aCell As Range
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Drawing Index")

With ws
For i = 2 To 99
    Set aCell = .Columns(1).find(What:="(" & i & " SHEETS)", LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
    If Not aCell Is Nothing Then
        aCell.EntireRow.Copy
        aCell.Resize(i - 1).EntireRow.Insert
    End If
    Application.StatusBar = "Duplicating rows containing (" & i & " SHEETS)..."
Next i
End With        
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

I've been told that its probably skipping the other matches because of the insert of new rows. How can i get around this? Is there another way.

EDIT_7.25.17
I am trying to get this code to run if a cell contains the text "SHEETS". I have tried a bunch of things and im stuck.

Sub ExpandRows_if()
Application.ScreenUpdating = False
Dim ws As Worksheet, l As Long, n As Long, s As Long, tmp As String, rng As range, SearchChar As String
Dim LastRow As Long, aCell As range
LastRow = range("A" & Rows.Count).End(xlUp).Row
Set rng = range("A3:A" & LastRow)
Set ws = ThisWorkbook.Sheets("Drawing Index")
SearchChar = "SHEETS"

With ws
For Each aCell In rng.Cells '(x)
    'If aCell.FormulaR1C1 = "=Countifs(rng.value,""*SHEETS)*""),1,0)" > 0 Then '(x)_This works as a formula on the sheet
    If InStr(1, aCell, SearchChar, vbTextCompare) > 0 Then '(x)_Other option i am trying
        For l = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
            s = InStr(1, .Cells(l, "A").Value2, "(")
            If CBool(s) Then
                n = val(Mid(.Cells(l, "A").Value2, s + 1))
                If n > 0 Then
                    .Cells(l + 1, "A").Resize(n-1).EntireRow.Insert
                    .Cells(1, "A").Resize(n + 1, 1).EntireRow.FillDown
                    Application.StatusBar = "Duplicating rows containing (" & n & " SHEETS)"
                End If
            End If
        Next l
    Else '(x)
        MsgBox "Damn! Still not working", vbOKOnly, "F*@&" '(x)
    Exit Sub '(x)
    End If '(x)
Next '(x)
End With

Application.ScreenUpdating = True
Application.StatusBar = vbNullString
End Sub

'(x) Indicates the new lines I added to get the IF statement working. Without these the code works but duplicates all rows. Well it should duplicate but the .FillDown doesn't seem to be working. ATM it is inserting the correct amount of rows.

Thanks

Upvotes: 0

Views: 190

Answers (1)

VBobCat
VBobCat

Reputation: 2732

The trouble with iterating the cells of rng is that, as you insert new rows, rng expands, which messes up your sequence. One should never iterate over a collection that is affected by the very iterating statements.

A more primitive approach, with pointer variables and a conditional loop, however, allow you to regain control of where you are in the worksheet.

Since I noticed your sample range starts on "A3" cell, I'd rather explicitly define a starting row (in variable FirstRow, so you can either parametrize your statement, or at least edit it in a tidy, self-explaining point, instead of delving down to more intrincate parts of your code.

As for tidiness, I also changed the fashion of Dim statements, for better readability.

So, this should do it (it worked on my tests):

Sub ExpandRows_if()
    Dim ws As Worksheet
    Dim n As Long
    Dim s As Long
    Dim e As Long
    Dim l As Long
    Dim nl As Long
    Dim tmp As String
    Dim SearchChar As String
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim aCell As Range

    Application.ScreenUpdating = False
    FirstRow = 1
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Set ws = ThisWorkbook.Sheets("Drawing Index")
    SearchChar = "SHEETS"

    With ws
        l = FirstRow
        Do
            Set aCell = .Cells(l, 1)
            If InStr(1, aCell, SearchChar, vbTextCompare) > 0 And _
               InStr(1, aCell, "(", vbTextCompare) > 0 Then
                s = InStr(1, aCell, "(", vbTextCompare)
                e = InStr(s, aCell, " ", vbTextCompare)
                n = Mid(aCell.Value, s + 1, e - s - 1)
                If n > 1 Then
                    Application.StatusBar = "Duplicating rows containing (" & n & " SHEETS)"
                    For nl = 1 To n - 1
                        aCell.Offset(nl, 0).EntireRow.Insert
                        aCell.Offset(nl, 0).Value = aCell.Value
                        LastRow = LastRow + 1 ' Since a row was inserted, last and
                        l = l + 1             ' current line pointers must increase by 1
                    Next
                End If
            End If
            l = l + 1 ' step to new line
        Loop While l <= LastRow
    End With

    Application.ScreenUpdating = True
    Application.StatusBar = vbNullString
End Sub

Upvotes: 2

Related Questions