Need to add a loop into current macro

[imeade]

I have the following code that works well for the static "LenderCode" reference; however, I need the macro to loop through the "LenderCode" range of "B4:B28" and run the same code for each value in the range

Sub Filter()

Dim i As Integer
Dim rngData As Range
Dim LenderCode As Range


Sheets("Data").Select
ActiveSheet.Range("a1").Select

Set rngData = Range("A1").CurrentRegion
i = Application.WorksheetFunction.Match("Reference-2", Range("A1:BZ1"), 0)

Set LenderCode = Sheets("Reference").Range("B4")

rngData.AutoFilter Field:=i, Criteria1:=LenderCode

Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste

End Sub



Thanks!
Ian

 

[HaHoBe]

Hi Ian,

what about

Sub Filter()

Dim lngMatch As Long
Dim rngData As Range
Dim rngWork As Range
Dim rngCell As Range
Dim wsData As Worksheet

Set wsData = Sheets("Data")
Set rngData = wsData.Range("A1").CurrentRegion
Set rngWork = Sheets("Reference").Range("B4:B28")

lngMatch = Application.WorksheetFunction.Match("Reference-2", wsData.Range("A1:BZ1"), 0)
For Each rngCell In rngWork
  With wsData
    rngData.AutoFilter Field:=lngMatch, Criteria1:=rngCell.Value
    rngData.SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add
    ActiveSheet.Paste
  End With
Next rngCell

Application.CutCopyMode = False
Set rngWork = Nothing
Set rngData = Nothing
wsData.AutoFilterMode = False
Set wsData = Nothing
End Sub

Ciao,
Holger

 

[imeade]

Hi Ian,

what about

Sub Filter()

Dim lngMatch As Long
Dim rngData As Range
Dim rngWork As Range
Dim rngCell As Range
Dim wsData As Worksheet

Set wsData = Sheets("Data")
Set rngData = wsData.Range("A1").CurrentRegion
Set rngWork = Sheets("Reference").Range("B4:B28")

lngMatch = Application.WorksheetFunction.Match("Reference-2", wsData.Range("A1:BZ1"), 0)
For Each rngCell In rngWork
  With wsData
    rngData.AutoFilter Field:=lngMatch, Criteria1:=rngCell.Value
    rngData.SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add
    ActiveSheet.Paste
  End With
Next rngCell

Application.CutCopyMode = False
Set rngWork = Nothing
Set rngData = Nothing
wsData.AutoFilterMode = False
Set wsData = Nothing
End Sub

Ciao,
Holger

Thanks! However, there are blank cells in the range so I would need the loop to not do anything if the reference cell is blank

 

[HaHoBe]

Hi Ian,

add a check like

For Each rngCell In rngWork
  If rngCell.Value <> "" Then
    With wsData
      rngData.AutoFilter Field:=lngMatch, Criteria1:=rngCell.Value
      rngData.SpecialCells(xlCellTypeVisible).Copy
      Sheets.Add
      ActiveSheet.Paste
    End With
  End If
Next rngCell

Holger

 

[imeade]

Hi Ian,

add a check like

For Each rngCell In rngWork
  If rngCell.Value <> "" Then
    With wsData
      rngData.AutoFilter Field:=lngMatch, Criteria1:=rngCell.Value
      rngData.SpecialCells(xlCellTypeVisible).Copy
      Sheets.Add
      ActiveSheet.Paste
    End With
  End If
Next rngCell

Holger

Fantastic, thank you. Can I please ask for one more addition. I would like the newly created sheet to be renamed to the respective reference that is in "Reference C4:C28".

Thanks again

 

[HaHoBe]

Hi Ian,

code takes care if a sheet with the name of the cell exists. So any exisitng sheet will be cleared before copying over, new sheets will be added if needed:

Sub Filter_mod3()
' https://www.mrexcel.com/board/threads/need-to-add-a-loop-into-current-macro.1227580/
'add sheets if not already in workbook
Dim lngMatch As Long
Dim rngData As Range
Dim rngWork As Range
Dim rngCell As Range
Dim wsData As Worksheet
Dim wsTarg As Worksheet

Set wsData = Sheets("Data")
Set rngData = wsData.Range("A1").CurrentRegion
Set rngWork = Sheets("Reference").Range("B4:B28")

lngMatch = Application.WorksheetFunction.Match("Reference-2", wsData.Range("A1:BZ1"), 0)
For Each rngCell In rngWork
  If rngCell.Value <> "" Then
    With wsData
      If Not Evaluate("ISREF('" & rngCell.Value & "'!A1)") Then
        Set wsTarg = Sheets.Add
        wsTarg.Name = rngCell.Value
      Else
        Set wsTarg = Sheets(rngCell.Value)
        wsTarg.Cells.Clear
        Application.Goto wsTarg.Cells(1, 1)
      End If
      rngData.AutoFilter Field:=lngMatch, Criteria1:=rngCell.Value
      rngData.SpecialCells(xlCellTypeVisible).Copy
      wsTarg.Paste
    End With
  End If
Next rngCell

Application.CutCopyMode = False
Set rngWork = Nothing
Set rngData = Nothing
wsData.AutoFilterMode = False
Set wsData = Nothing
End Sub

Ciao,
Holger