VBA to escape to next set of code if no data were found

M

Martin sherk

Board Regular
Joined
Sep 11, 2022
Messages
94
Office Version
  1. 365
  2. 2016
Hello All

so what am looking for is a VBA code where I can escape to the next set of code when there is no data in the filtered range, I can't do it with multiple sheets and long sets of code as the stated below.

VBA Code: 
Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:I").Select
    Selection.Delete Shift:=xlToLeft
' 1st Step: Pivot Table

   ' to catch the last row there
    Lr = Cells(Rows.Count, 1).End(xlUp).Row
    ' to catch the last column
    Lc = Cells(1, Columns.Count).End(xlToLeft).Column
    
    If Lr < 2 Then
    Exit Sub
    End If
    
    MainWS = ActiveSheet.Name
    
    Sheets.Add
    pivotWS = ActiveSheet.Name
    
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
       "'" & MainWS & "'!A1:X" & Lr, Version:=6).CreatePivotTable TableDestination:= _
        pivotWS & "!R3C1", TableName:="PivotTable1", DefaultVersion:=6
    Sheets(pivotWS).Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Company Code")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Business code")
        .Orientation = xlRowField
        .Position = 2
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
        "Amount in local currency")
        .Orientation = xlRowField
        .Position = 3
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("Amount in local currency"), _
        "Count of Amount in local currency", xlCount
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Account")
        .Orientation = xlRowField
        .Position = 3
    End With
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Company Code").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Company Code")
        .LayoutForm = xlTabular
        .RepeatLabels = True
    End With
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Business code"). _
        Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
        False, False)
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Business code")
        .LayoutForm = xlTabular
        .RepeatLabels = True
    End With
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Account").Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Account")
        .LayoutForm = xlTabular
        .RepeatLabels = True
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
        "Count of Amount in local currency")
        .Caption = "Sum of Amount in local currency"
        .Function = xlSum
    End With
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Business code"). _
        LayoutBlankLine = True
    ActiveWindow.SmallScroll Down:=-6
    Columns("D:D").Select
    Selection.Style = "Comma"
 'rename the sheet to pivot
 
 ActiveSheet.Name = "Pivot"
 
'start filtering and copying
       
 
 
With Worksheets("Sheet1").Range("A1")
.AutoFilter Field:=1, Criteria1:="Al1"
.AutoFilter Field:=3, Criteria1:="2789001"
.AutoFilter Field:=2, Criteria1:="ADR"

Dim rng As Range
Dim ws As Worksheet
If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "AL1 - ADR"
 rng.Copy Range("A1")


    

End With

With Worksheets("Sheet1").Range("A1")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData

.AutoFilter Field:=1, Criteria1:="ADR"
.AutoFilter Field:=3, Criteria1:="1542001"
.AutoFilter Field:=2, Criteria1:="AL1"

'Set variables
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim iSourceLastRow As Long
Dim iTargetLastRow As Long
'Set variables for source and destination sheets
Set wsSource = Worksheets("Sheet1")
Set wsTarget = Worksheets("ADR - AL1")
'Find last used row in the source sheet based on data in column B
iSourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'Find first blank row in the destination sheet based on data in column B
'Offset property is to move the copied data 1 row down
iTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(5).Row
'Copy data from the source and Paste in the destination

Set rng = Worksheets("Sheet1").AutoFilter.Range.Offset(0)
    

rng.Copy wsTarget.Range("A" & iTargetLastRow)

Columns("L:M").Insert
 Range("L1").Value = "Reconcile"
 Range("M1").Value = "Yes"
Dim rng1 As Range, rng2 As Range
  
  Set rng1 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(1)
  Set rng2 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(2)
  Intersect(rng1.EntireRow, Columns("A:Y")).Sort Key1:=rng1, Order1:=xlAscending, Header:=xlNo
  Intersect(rng2.EntireRow, Columns("A:Y")).Sort Key1:=rng2, Order1:=xlAscending, Header:=xlNo
  rng1.Offset(, 1).Resize(, 2).Formula = Array( _
    "=INT(ABS(K2))&"" - ""&COUNTIF(L$1:L1,INT(ABS(K2))&"" -*"")+1", _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L2)=2,""x"","""")")
 rng2.Offset(, 1).Resize(, 2).Formula = Array( _
    Replace(Replace("=INT(ABS(K#))&"" - ""&COUNTIF(L$%:L%,INT(ABS(K#))&"" -*"")+1", "#", rng2.Row), "%", rng2.Row - 1), _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L" & rng2.Row & ")=2,""x"","""")")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData

    
' Color the filtered numbers that matches
'Create variables to hold the number of rows for the tabular data
Dim RRow As Long, N As Long
'Capture the number of rows within the tabular data range
RRow = ActiveSheet.UsedRange.Rows.Count
'Iterate through all the rows in the tabular data range
For N = 1 To RRow
    'Use a Select Case statement to evaluate the formatting based on column 2
    Select Case ActiveSheet.Cells(N, 13).Value
        'Turn the interior color to blue
        Case "x"
        ActiveSheet.Cells(N, 11).Interior.Color = RGB(204, 255, 204)
        'Turn the interior color to red
    End Select
        Select Case ActiveSheet.Cells(N, 13).Value
        Case "x"
        ActiveSheet.Cells(N, 12).Interior.Color = RGB(204, 255, 204)

    End Select

Next N




With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="ESL"
.AutoFilter Field:=3, Criteria1:="2780001"
.AutoFilter Field:=2, Criteria1:="ASL"



If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "ESL - ASL"
 rng.Copy Range("A1")
 

End With

With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="ASL"
.AutoFilter Field:=3, Criteria1:="1680001"
.AutoFilter Field:=2, Criteria1:="ESL"

'Set variables



'Set variables for source and destination sheets
Set wsSource = Worksheets("Sheet1")
Set wsTarget = Worksheets("ASL - ESL")
'Find last used row in the source sheet based on data in column B
iSourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'Find first blank row in the destination sheet based on data in column B
'Offset property is to move the copied data 1 row down
iTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(5).Row
'Copy data from the source and Paste in the destination

Set rng = Worksheets("Sheet1").AutoFilter.Range.Offset(0)
    

rng.Copy wsTarget.Range("A" & iTargetLastRow)

 Columns("L:M").Insert
 Range("L1").Value = "Reconcile"
 Range("M1").Value = "Yes"
 Set rng1 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(1)
  Set rng2 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(2)
  Intersect(rng1.EntireRow, Columns("A:Y")).Sort Key1:=rng1, Order1:=xlAscending, Header:=xlNo
  Intersect(rng2.EntireRow, Columns("A:Y")).Sort Key1:=rng2, Order1:=xlAscending, Header:=xlNo
  rng1.Offset(, 1).Resize(, 2).Formula = Array( _
    "=INT(ABS(K2))&"" - ""&COUNTIF(L$1:L1,INT(ABS(K2))&"" -*"")+1", _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L2)=2,""x"","""")")
 rng2.Offset(, 1).Resize(, 2).Formula = Array( _
    Replace(Replace("=INT(ABS(K#))&"" - ""&COUNTIF(L$%:L%,INT(ABS(K#))&"" -*"")+1", "#", rng2.Row), "%", rng2.Row - 1), _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L" & rng2.Row & ")=2,""x"","""")")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData


RRow = ActiveSheet.UsedRange.Rows.Count
'Iterate through all the rows in the tabular data range
For N = 1 To RRow
    'Use a Select Case statement to evaluate the formatting based on column 2
    Select Case ActiveSheet.Cells(N, 13).Value
        'Turn the interior color to blue
        Case "x"
        ActiveSheet.Cells(N, 11).Interior.Color = RGB(204, 255, 204)
        'Turn the interior color to red
    End Select
        Select Case ActiveSheet.Cells(N, 13).Value
        Case "x"
        ActiveSheet.Cells(N, 12).Interior.Color = RGB(204, 255, 204)

    End Select

Next N



        
        
End With
With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="ESL"
.AutoFilter Field:=3, Criteria1:="7985501"
.AutoFilter Field:=2, Criteria1:="ASL"



If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "ESL - ASL"
 rng.Copy Range("A1")
 

End With

With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="ASL"
.AutoFilter Field:=3, Criteria1:="6789440"
.AutoFilter Field:=2, Criteria1:="ESL"

'Set variables



'Set variables for source and destination sheets
Set wsSource = Worksheets("Sheet1")
Set wsTarget = Worksheets("ASL- ESL")
'Find last used row in the source sheet based on data in column B
iSourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'Find first blank row in the destination sheet based on data in column B
'Offset property is to move the copied data 1 row down
iTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(5).Row
'Copy data from the source and Paste in the destination

Set rng = Worksheets("Sheet1").AutoFilter.Range.Offset(0)
    

rng.Copy wsTarget.Range("A" & iTargetLastRow)

 Columns("L:M").Insert
 Range("L1").Value = "Reconile"
 Range("M1").Value = "Yes"
 Set rng1 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(1)
  Set rng2 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(2)
  Intersect(rng1.EntireRow, Columns("A:Z")).Sort Key1:=rng1, Order1:=xlAscending, Header:=xlNo
  Intersect(rng2.EntireRow, Columns("A:Z")).Sort Key1:=rng2, Order1:=xlAscending, Header:=xlNo
  rng1.Offset(, 1).Resize(, 2).Formula = Array( _
    "=INT(ABS(K2))&"" - ""&COUNTIF(L$1:L1,INT(ABS(K2))&"" -*"")+1", _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L2)=2,""x"","""")")
  rng2.Offset(, 1).Resize(, 2).Formula = Array( _
    Replace(Replace("=INT(ABS(K#))&"" - ""&COUNTIF(L$%:L%,INT(ABS(K#))&"" -*"")+1", "#", rng2.Row), "%", rng2.Row - 1), _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L" & rng2.Row & ")=2,""x"","""")")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData


RRow = ActiveSheet.UsedRange.Rows.Count
'Iterate through all the rows in the tabular data range
For N = 1 To RRow
    'Use a Select Case statement to evaluate the formatting based on column 2
    Select Case ActiveSheet.Cells(N, 13).Value
        'Turn the interior color to blue
        Case "x"
        ActiveSheet.Cells(N, 11).Interior.Color = RGB(204, 255, 204)
        'Turn the interior color to red
    End Select
        Select Case ActiveSheet.Cells(N, 13).Value
        Case "x"
        ActiveSheet.Cells(N, 12).Interior.Color = RGB(204, 255, 204)

    End Select

Next N




End With


With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="FSL"
.AutoFilter Field:=3, Criteria1:="4855158"
.AutoFilter Field:=2, Criteria1:="ASL"



If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "FSL - ASL"
 rng.Copy Range("A1")
 

End With


With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="ASL"
.AutoFilter Field:=3, Criteria1:="6800023"
.AutoFilter Field:=2, Criteria1:="FSL"


'Set variables


'Set variables for source and destination sheets
Set wsSource = Worksheets("Sheet1")
Set wsTarget = Worksheets("ASL - FSL")

'Find last used row in the source sheet based on data in column B
iSourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'Find first blank row in the destination sheet based on data in column B
'Offset property is to move the copied data 1 row down
iTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(5).Row
'Copy data from the source and Paste in the destination

Set rng = Worksheets("Sheet1").AutoFilter.Range.Offset(0)
    

rng.Copy wsTarget.Range("A" & iTargetLastRow)

 Columns("L:M").Insert
 Range("L1").Value = "Reconcile"
 Range("M1").Value = "Yes"

Set rng1 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(1)
  Set rng2 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(2)
  Intersect(rng1.EntireRow, Columns("A:Z")).Sort Key1:=rng1, Order1:=xlAscending, Header:=xlNo
  Intersect(rng2.EntireRow, Columns("A:Z")).Sort Key1:=rng2, Order1:=xlAscending, Header:=xlNo
  rng1.Offset(, 1).Resize(, 2).Formula = Array( _
    "=INT(ABS(K2))&"" - ""&COUNTIF(L$1:L1,INT(ABS(K2))&"" -*"")+1", _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L2)=2,""x"","""")")
  rng2.Offset(, 1).Resize(, 2).Formula = Array( _
    Replace(Replace("=INT(ABS(K#))&"" - ""&COUNTIF(L$%:L%,INT(ABS(K#))&"" -*"")+1", "#", rng2.Row), "%", rng2.Row - 1), _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L" & rng2.Row & ")=2,""x"","""")")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData


RRow = ActiveSheet.UsedRange.Rows.Count
'Iterate through all the rows in the tabular data range
For N = 1 To RRow
    'Use a Select Case statement to evaluate the formatting based on column 2
    Select Case ActiveSheet.Cells(N, 13).Value
        'Turn the interior color to blue
        Case "x"
        ActiveSheet.Cells(N, 11).Interior.Color = RGB(204, 255, 204)
        'Turn the interior color to red
    End Select
        Select Case ActiveSheet.Cells(N, 13).Value
        Case "x"
        ActiveSheet.Cells(N, 12).Interior.Color = RGB(204, 255, 204)

    End Select

Next N


         
         


With Worksheets("Sheet1").Range("A1")
.AutoFilter Field:=1, Criteria1:="IRE"
.AutoFilter Field:=3, Criteria1:="98565465"
.AutoFilter Field:=2, Criteria1:="REC"



If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "IRE- REC"
 rng.Copy Range("A1")


    

End With

With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="REC"
.AutoFilter Field:=3, Criteria1:="98555452"
.AutoFilter Field:=2, Criteria1:="IRE"

'Set variables


'Set variables for source and destination sheets
Set wsSource = Worksheets("Sheet1")
Set wsTarget = Worksheets("REC- IRE")
'Find last used row in the source sheet based on data in column B
iSourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'Find first blank row in the destination sheet based on data in column B
'Offset property is to move the copied data 1 row down
iTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(5).Row
'Copy data from the source and Paste in the destination

Set rng = Worksheets("Sheet1").AutoFilter.Range.Offset(0)
    

rng.Copy wsTarget.Range("A" & iTargetLastRow)

 Columns("L:M").Insert
 Range("L1").Value = "Reconcile"
 Range("M1").Value = "YES"
 
Set rng1 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(1)
  Set rng2 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(2)
  Intersect(rng1.EntireRow, Columns("A:Z")).Sort Key1:=rng1, Order1:=xlAscending, Header:=xlNo
  Intersect(rng2.EntireRow, Columns("A:Z")).Sort Key1:=rng2, Order1:=xlAscending, Header:=xlNo
  rng1.Offset(, 1).Resize(, 2).Formula = Array( _
    "=INT(ABS(K2))&"" - ""&COUNTIF(L$1:L1,INT(ABS(K2))&"" -*"")+1", _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L2)=2,""x"","""")")
  rng2.Offset(, 1).Resize(, 2).Formula = Array( _
    Replace(Replace("=INT(ABS(K#))&"" - ""&COUNTIF(L$%:L%,INT(ABS(K#))&"" -*"")+1", "#", rng2.Row), "%", rng2.Row - 1), _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L" & rng2.Row & ")=2,""x"","""")")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData


RRow = ActiveSheet.UsedRange.Rows.Count
'Iterate through all the rows in the tabular data range
For N = 1 To RRow
    'Use a Select Case statement to evaluate the formatting based on column 2
    Select Case ActiveSheet.Cells(N, 13).Value
        'Turn the interior color to blue
        Case "x"
        ActiveSheet.Cells(N, 11).Interior.Color = RGB(204, 255, 204)
        'Turn the interior color to red
    End Select
        Select Case ActiveSheet.Cells(N, 13).Value
        Case "x"
        ActiveSheet.Cells(N, 12).Interior.Color = RGB(204, 255, 204)

    End Select

Next N


        
With Worksheets("Sheet1").Range("A1")
.AutoFilter Field:=1, Criteria1:="IRA"
.AutoFilter Field:=3, Criteria1:="5454545"
.AutoFilter Field:=2, Criteria1:="RBA"



If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "IRA- RBA"
 rng.Copy Range("A1")


    

End With

With Worksheets("Sheet1").Range("A1")
ActiveSheet.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:="RBA"
.AutoFilter Field:=3, Criteria1:="545445415"
.AutoFilter Field:=2, Criteria1:="IRA"

'Set variables


'Set variables for source and destination sheets
Set wsSource = Worksheets("Sheet1")
Set wsTarget = Worksheets("RBA- IRA")
'Find last used row in the source sheet based on data in column B
iSourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'Find first blank row in the destination sheet based on data in column B
'Offset property is to move the copied data 1 row down
iTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(5).Row
'Copy data from the source and Paste in the destination

Set rng = Worksheets("Sheet1").AutoFilter.Range.Offset(0)
    

rng.Copy wsTarget.Range("A" & iTargetLastRow)
'insert 2 new columns and add our Recon formulas
 Columns("L:M").Insert
 Range("L1").Value = "Reconcile"
 Range("M1").Value = "Yes"

  
  Set rng1 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(1)
  Set rng2 = Columns("K").SpecialCells(xlConstants, xlNumbers).Areas(2)
  Intersect(rng1.EntireRow, Columns("A:Z")).Sort Key1:=rng1, Order1:=xlAscending, Header:=xlNo
  Intersect(rng2.EntireRow, Columns("A:Z")).Sort Key1:=rng2, Order1:=xlAscending, Header:=xlNo
  rng1.Offset(, 1).Resize(, 2).Formula = Array( _
    "=INT(ABS(K2))&"" - ""&COUNTIF(L$1:L1,INT(ABS(K2))&"" -*"")+1", _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L2)=2,""x"","""")")
 rng2.Offset(, 1).Resize(, 2).Formula = Array( _
    Replace(Replace("=INT(ABS(K#))&"" - ""&COUNTIF(L$%:L%,INT(ABS(K#))&"" -*"")+1", "#", rng2.Row), "%", rng2.Row - 1), _
    "=IF(COUNTIF($L$2:$L$" & rng2.Row + rng2.Rows.Count - 1 & ",L" & rng2.Row & ")=2,""x"","""")")
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData



RRow = ActiveSheet.UsedRange.Rows.Count
'Iterate through all the rows in the tabular data range
For N = 1 To RRow
    'Use a Select Case statement to evaluate the formatting based on column 2
    Select Case ActiveSheet.Cells(N, 13).Value
        'Turn the interior color to blue
        Case "x"
        ActiveSheet.Cells(N, 11).Interior.Color = RGB(204, 255, 204)
        'Turn the interior color to red
    End Select
        Select Case ActiveSheet.Cells(N, 13).Value
        Case "x"
        ActiveSheet.Cells(N, 12).Interior.Color = RGB(204, 255, 204)

    End Select

Next N


        
  
'Turn off autofilter in the main data sheet
     For Each ws In ActiveWorkbook.Worksheets
    If ws.AutoFilterMode = True Then
      ws.AutoFilterMode = False
    End If
  Next ws
  
'Autofilter for entries with No trading partners
With Worksheets("Sheet1").Range("A1")
.AutoFilter Field:=2, Criteria1:="="
Set rng = Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "No Business Partner"
 rng.Copy Range("A1")
 
 
 'Turn off autofilter in the main data sheet again
 For Each ws In ActiveWorkbook.Worksheets
    If ws.AutoFilterMode = True Then
      ws.AutoFilterMode = False
      If ws.Name <> "Sheet1" Then ws.Columns("L:M").Hidden = True
    End If
  Next ws
 


  For Each ws In ActiveWorkbook.Worksheets
 If ws.Name <> "Sheet1" Then ws.Columns("L:M").Hidden = True
    
  Next ws
End With
End With
End With
End With
End With
End Sub
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Hi Martin,

Although it would appear that it would be helpful to provide what appears to be all of your code for us, please respect our time and post the specific part of your code that you are having problems with. Thank you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Delete row if field contains Apostrophe
Replies
3
Views
69
Peterfc2
P
N
  • Question Question
AutoFilter Field Macro Returns a Header Row only
2
Replies
11
Views
102
MARK858
MARK858
H
  • Question Question
Add a criteria to VBA Code
Replies
8
Views
365
hrayani
H
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
624
myall_blues
myall_blues
S
  • Solved
Return error if "Filter" doesn't return the required entry
Replies
2
Views
146
skittlz
S

Forum statistics

Threads
1,223,893
Messages
6,175,249
Members
452,623
Latest member
Techenthusiast

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