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

S

slohman

Board Regular
Joined
Mar 31, 2012
Messages
110
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.

TypeSKUNameCategoriesAA2
simpleSS10-3000SS10-3000Play > Essentials Timber, Play > Multi-Age Combinations, Play
simpleSS10-3001SS10-3001Play > Essentials, Play > Multi-Age Combinations, Play
simpleSS11-3000SS11-3000Play > Essentials, Play > Multi-Age Combinations, Play
simpleSS12-3000SS12-3000Play > Essentials, Play > Multi-Age Combinations, Play
simpleSS1-3000SS1-3000Play > Essentials, Play > Multi-Age Combinations, Play
simpleSS13-3000SS13-3000Play > Essentials, Play > Multi-Age Combinations, Play
simpleSS17-3000SS17-3000Play > Essentials Timber, Play > Multi-Age Combinations, Play
simpleSS21-3000SS21-3000Play > Essentials, Play > Multi-Age Combinations, Play
simpleSS2-3000SS2-3000Play > Essentials, Play > Multi-Age Combinations, Play

VBA Code: 
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
 
Sort by date Sort by votes
Using "Exit For", or "Go to", like this:

Exit the current "for" and back to previous "for"
VBA Code: 
For ...
     For ....
          If .... then
             <action>
             Exit For
          End if
      Next
Next

Or
Exit to a position (Z):
VBA Code: 
For ...
     For ....
          If .... then
             <action>
             GoTo Z
          End if
      Next
Next
Z:
<Do something else>
End sub
 
Upvote 0
This is a guess since I'm not clear about what you are trying to do.
VBA Code: 
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
 
Upvote 0
bebo021999 said:
Using "Exit For", or "Go to", like this:

Exit the current "for" and back to previous "for"
VBA Code: 
For ...
     For ....
          If .... then
             <action>
             Exit For
          End if
      Next
Next

Or
Exit to a position (Z):
VBA Code: 
For ...
     For ....
          If .... then
             <action>
             GoTo Z
          End if
      Next
Next
Z:
<Do something else>
End sub
Click to expand...
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.

VBA Code: 
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
 
Upvote 0
This is what I'm getting
Play Essentials
Freestanding > Freestanding Swings
TypeSKUNameCategoriesAA2
simpleSS10-3000SS10-3000Play > Essentials Timber, Play > Multi-Age Combinations, Play
simpleSS10-3001SS10-3001Play > Essentials, Play > Multi-Age Combinations, Play
TypeSKUNameCategoriesAA2
simpleSTSW50E3.5m Swing Double PolishedFreestanding > Freestanding Swings, Play
simpleSTSW98E3m Swing Double PolishedFreestanding > Freestanding Swings, Play

This is what I would like
Play Essentials
TypeSKUNameCategoriesAA2
simpleSS10-3000SS10-3000Play > Essentials Timber, Play > Multi-Age Combinations, Play
simpleSS10-3001SS10-3001Play > Essentials, Play > Multi-Age Combinations, Play
Freestanding > Freestanding Swings
TypeSKUNameCategoriesAA2
simpleSTSW50E3.5m Swing Double PolishedFreestanding > Freestanding Swings, Play
simpleSTSW98E3m Swing Double PolishedFreestanding > Freestanding Swings, Play
 
Upvote 0
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).
 
Upvote 0
bebo021999 said:
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).
Click to expand...
1686126608475.png


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

VBA Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA Macro if critieria is met place text in blank row of column A
Replies
2
Views
340
slohman
S

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top