VBA Macro to exit sub if first criteria is met - no looping

[slohman]

I would like my macro to stop after first criteria is met, I dont want it to loop through my spreadsheet as it has 100's of rows.

Type	SKU	Name						CategoriesAA2
simple	SS10-3000	SS10-3000						Play > Essentials Timber, Play > Multi-Age Combinations, Play
simple	SS10-3001	SS10-3001						Play > Essentials, Play > Multi-Age Combinations, Play
simple	SS11-3000	SS11-3000						Play > Essentials, Play > Multi-Age Combinations, Play
simple	SS12-3000	SS12-3000						Play > Essentials, Play > Multi-Age Combinations, Play
simple	SS1-3000	SS1-3000						Play > Essentials, Play > Multi-Age Combinations, Play
simple	SS13-3000	SS13-3000						Play > Essentials, Play > Multi-Age Combinations, Play
simple	SS17-3000	SS17-3000						Play > Essentials Timber, Play > Multi-Age Combinations, Play
simple	SS21-3000	SS21-3000						Play > Essentials, Play > Multi-Age Combinations, Play
simple	SS2-3000	SS2-3000						Play > Essentials, Play > Multi-Age Combinations, Play

Sub PlayEssentials()
Dim c As Range
Dim d As Range

    For Each c In Range("A1:A1000")
    For Each d In Range("J1:J1000")
        If c.Value Like "*Type*" And d.Value Like "*Play > Essentials*" Then
            c.EntireRow.Resize(3).Insert
            c.Offset(-1).Value = "Play Essentials"

End Sub

 

[bebo021999]

Using "Exit For", or "Go to", like this:

Exit the current "for" and back to previous "for"

For ...
     For ....
          If .... then
             <action>
             Exit For
          End if
      Next
Next

Or
Exit to a position (Z):

For ...
     For ....
          If .... then
             <action>
             GoTo Z
          End if
      Next
Next
Z:
<Do something else>
End sub

 

[rlv01]

This is a guess since I'm not clear about what you are trying to do.

Sub PlayEssentials()
    Dim c As Range
    Dim d As Range

    For Each c In Range("A1:A1000")
        'For Each d In Range("J1:J1000")
        If c.Value Like "*Type*" And c.Offset(0, 9).Value Like "*Play > Essentials*" Then
            c.EntireRow.Resize(3).Insert
            c.Offset(-1).Value = "Play Essentials"
            Exit Sub                                  'exit after first criteria is met
        End If
    Next c
    MsgBox "Criteria not found. ", vbOKOnly Or vbInformation, Application.Name
End Sub

 

[slohman]

Using "Exit For", or "Go to", like this:

Exit the current "for" and back to previous "for"

For ...
     For ....
          If .... then
             <action>
             Exit For
          End if
      Next
Next

Or
Exit to a position (Z):

For ...
     For ....
          If .... then
             <action>
             GoTo Z
          End if
      Next
Next
Z:
<Do something else>
End sub

Can something like this be added I'm getting a compile error next without for after on second last next, I have made it bold where the error is.

Sub PlayEssentials()
Dim c As Range
Dim d As Range

    For Each c In Range("A1:A1000")
    For Each d In Range("J1:J1000")
        If c.Value Like "*Type*" And d.Value Like "*Play > Essentials*" Then
            c.EntireRow.Resize(3).Insert
            c.Offset(-1).Value = "Play Essentials"
GoTo Z
          End If
      Next
Next
Z:
        If c.Value Like "*Type*" And d.Value Like "*Swings*" Then
            c.EntireRow.Resize(3).Insert
            c.Offset(-1).Value = "Freestanding Swings"
GoTo Z
          End If
      [B][U]Next[/U][/B]
Next
Z:

End Sub

 

[slohman]

This is what I'm getting

Play Essentials
Freestanding > Freestanding Swings
Type	SKU	Name	CategoriesAA2
simple	SS10-3000	SS10-3000	Play > Essentials Timber, Play > Multi-Age Combinations, Play
simple	SS10-3001	SS10-3001	Play > Essentials, Play > Multi-Age Combinations, Play
Type	SKU	Name	CategoriesAA2
simple	STSW50E	3.5m Swing Double Polished	Freestanding > Freestanding Swings, Play
simple	STSW98E	3m Swing Double Polished	Freestanding > Freestanding Swings, Play

This is what I would like

Play Essentials
Type	SKU	Name	CategoriesAA2
simple	SS10-3000	SS10-3000	Play > Essentials Timber, Play > Multi-Age Combinations, Play
simple	SS10-3001	SS10-3001	Play > Essentials, Play > Multi-Age Combinations, Play
Freestanding > Freestanding Swings
Type	SKU	Name	CategoriesAA2
simple	STSW50E	3.5m Swing Double Polished	Freestanding > Freestanding Swings, Play
simple	STSW98E	3m Swing Double Polished	Freestanding > Freestanding Swings, Play

 

[bebo021999]

I can not see the row/column Index. Could you send screenshot (after hide other columns) to show row/column indexes?
It seems you must use array to store data, loop this array then copy to another array in right order (Essential,then Swing next).

 

[slohman]

I can not see the row/column Index. Could you send screenshot (after hide other columns) to show row/column indexes?
It seems you must use array to store data, loop this array then copy to another array in right order (Essential,then Swing next).

This is the macro that I'm using and would like to either add your code or create code that I call on each paste

Sub FilteredDataSelection()
Dim wsProducts As Worksheet
Dim wsProductsCopied As Worksheet
Dim WsPriceList As Worksheet
Dim lngLastrow  As Long
Dim strCategory As String
Dim i As Integer
Dim rngCategories As Range
Dim rng As Range
Dim intRow As Integer
Dim LastRow As Long, erow As Long
Dim c As Range
Dim d As Range


    'ActiveWorkbook.Save
    
    Call subDeleteWorksheet("ProductsCopied")
    Call subDeleteWorksheet("Price List")
    
    Sheets.Add.Name = "ProductsCopied"
    
    ' Create Price List sheet.
    Worksheets.Add After:=Worksheets("ProductsCopied")
    ActiveSheet.Name = "Price List"
    
    Set WsPriceList = Worksheets("Price List")
    
    Set wsProductsCopied = Worksheets("ProductsCopied")
 
    Set wsProducts = ThisWorkbook.Worksheets("Products")
 
    Sheets("Products").Activate
    

 'Clear any existing filters
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

  '1. Apply Filter
   ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=11, Criteria1:="=Play > Essentials*"

  '2. Copy Rows minus the header
    Application.DisplayAlerts = False

   wsProducts.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy 'copy the AF first
  
   Set rng = wsProducts.UsedRange.Offset(0, 1)
   Set rng = rng.Resize(rng.Rows.Count)
  
   rng.Copy
 
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("ProductsCopied").Activate
 
  lr = ThisWorkbook.Worksheets("ProductsCopied").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
  Range("A" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Call PlayEssentials
    
  Application.DisplayAlerts = True

'4. Clear Filter from original sheet
    On Error Resume Next
    wsProducts.ShowAllData
    On Error GoTo 0
 
    
    Sheets("Products").Activate
    ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=11, Criteria1:="=*Swings,*" ' im filtering by anything in col 24 that contains "P24128"


   wsProducts.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy 'copy the AF first
  
   Set rng = wsProducts.UsedRange.Offset(0, 1)
   Set rng = rng.Resize(rng.Rows.Count)
  
   rng.Copy
 
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("ProductsCopied").Activate
  lr = ThisWorkbook.Worksheets("ProductsCopied").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 3
  Range("A" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    

    Sheets("Products").Activate
    ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=11, Criteria1:="=*Springs & Rockers,*" ' im filtering by anything in col 24 that contains "P24128"

  '2. Copy Rows minus the header
    Application.DisplayAlerts = False

   wsProducts.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy 'copy the AF first
  
   Set rng = wsProducts.UsedRange.Offset(0, 1)
   Set rng = rng.Resize(rng.Rows.Count)
  
   rng.Copy
 
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("ProductsCopied").Activate
  lr = ThisWorkbook.Worksheets("ProductsCopied").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 3
  Range("A" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    

'Call Freestanding_Swings
    
  Application.DisplayAlerts = True
 
    Sheets("Products").Activate
    
    If wsProducts.AutoFilterMode Then
    ActiveSheet.AutoFilterMode = False
    End If

    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    'Will delete worksheet when macro is correct
    subDeleteWorksheet ("Price List")
    
    Sheets("ProductsCopied").Activate
    ActiveSheet.Name = "Price List"
    
    'WsPriceList.Cells.EntireColumn.AutoFit
    
    Call subDeleteColumn(WsPriceList, "Mark Up%")
    Call subDeleteColumn(WsPriceList, "ALP Price")
    Call subDeleteColumn(WsPriceList, "SKU and Name Match")
    Call subDeleteColumn(WsPriceList, "Short Descrip H2")
    Call subDeleteColumn(WsPriceList, "Tags AB2")
    Call subDeleteColumn(WsPriceList, "JPG AD2")
    Call subDeleteColumn(WsPriceList, "DWG BD2")
    Call subDeleteColumn(WsPriceList, "PDF BH2")
    Call subDeleteColumn(WsPriceList, "Tech PDF BX2")
    Call subDeleteColumn(WsPriceList, "Focus DE2")
    Call subDeleteColumn(WsPriceList, "CategoriesAA2")
    
    ActiveSheet.Columns("A:J").AutoFit

    Range("A:F").Font.Size = 9
    Range("A:F").Font.Color = vbBlack
    Range("A:F").Font.Name = "Calibri Light"
    Range("D:D").HorizontalAlignment = xlRight
    Range("D:D").NumberFormat = "$#,##0.00"
    Range("A1").Select
    'Range("A2:F2").Font.Size = 12
    'Range("A2:F2").Font.Bold = True
    

    'WsPricelist.Columns(1).ClearContents
    
    ActiveWorkbook.Save

End Sub
  
   Private Sub subDeleteWorksheet(strWorksheet As String)

    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets(strWorksheet).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
End Sub

Private Sub subDeleteColumn(ws As Worksheet, strHeader As String)
Dim rngFound As Range

    Set rngFound = Worksheets("Price list").Rows(2).Find(strHeader, LookIn:=xlValues)

    If Not rngFound Is Nothing Then
        rngFound.EntireColumn.Delete
    End If

End Sub