Loop through filtered data VBA

[Alcalore]

Good morning,

I seem to have run into a problem with how my rngVisible is defined - there is a header in rngSource in Row2, that is the reason for why I offset by one row. I have also checked the filter applied and they are being applied correctly during each loop.

I have added two debug lines to see the first and last visible cell in the source list after applying the filters and for some reason it only detects the first visible cell in column A - A13 and last visible cell detected is also A13, when in reality the first on the rngSource is A13, but the last visible cell is A222

This causes my For counter loop to skip the copy part of the code since agents variable in this case is 10, counter goes higher than the one visible cell (A13)

Could anyone kinldy help?

'Agents Loop
For i = 6 To ThisWorkbook.Worksheets("Pivot").UsedRange.Rows.Count
country = ThisWorkbook.Worksheets("Pivot").Cells(i, 7).Value
agents = ThisWorkbook.Worksheets("Pivot").Cells(i, 10).Value

rngSource.AutoFilter Field:=16, Criteria1:=country, Operator:=xlFilterValues
rngSource.AutoFilter Field:=25, Criteria1:="3", Operator:=xlFilterValues
rngSource.AutoFilter Field:=26, Criteria1:="No", Operator:=xlFilterValues
rngSource.AutoFilter Field:=23, Criteria1:="HR services", Operator:=xlFilterValues

rngSource.Sort Key1:=rngSource.Columns(27), Order1:=xlAscending, Header:=xlYes

On Error Resume Next
Set rngVisible = rngSource.Offset(1, 0).Resize(rngSource.Rows.Count - 1).Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set copyDestination = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
If copyDestination.Row < 3 Then

Set copyDestination = wsDest.Range("A3")
End If

For counter = 1 To agents
If counter <= rngVisible.Rows.Count Then
rngVisible.Cells(counter).Copy copyDestination
Set copyDestination = copyDestination.Offset(1, 0)
End If
Next counter

wsSource.AutoFilterMode = False

Next i

 

[kevin9999]

I can't really tell from your code, but is there a reason why you're copying one (visible) row at a time to the wsDest sheet - and not copying en masse? It would help those trying to help you if you could provide a sample of your data using the XL2BB add in (no images please) or alternatively share your file via Google Drive, Dropbox or similar file sharing platform. Your full code would also help.

 

[Alcalore]

Sorry, I'm still very new to VBA, by using the variable "agents" I wanted to determine the ammount of visible cells that need to be copied - this variable changes in each "For i" loop
The reason for sorting is the sorted column contains RAND() and this way I get a random sample of the "agents" variable.
If there is a way to do this without looping through the cells one at a time, I'd absolutely love that!

Please find a sample of the wsSource in the Dropbox:

Source sample.xlsx

Shared with Dropbox

www.dropbox.com

As for wsDest it is a blank sheet with a header in Row2 and I wish to input the data in column A below the header

Please find the code below and sorry for the long read:

Sub FilterSortCopy()
Dim wsSource As Worksheet, wsDest As Worksheet, wsDestS As Worksheet, wsDestN As Worksheet
Dim rngSource As Range, rngVisible As Range, cell As Range, rngSpecialist As Range
Dim lastRow As Long, lastRowSpecialist As Long
Dim loopCount As Integer
Dim copyDestination As Range
Dim i As Long
Dim country As String, agents As String, specialists As String, specialist As String
Dim cellInColumnA As Range
Dim celltoTypeY As Range


Set wsSource = ThisWorkbook.Sheets("Case data report")

Set wsDest = ThisWorkbook.Sheets("Final Report Agents")

Set wsDestS = ThisWorkbook.Sheets("Final Report Specialists")

Set wsDestN = ThisWorkbook.Sheets("Final Report Newcomers")

lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

Set rngSource = wsSource.Range("A2:AA" & lastRow)


'Agents Loop
For i = 6 To ThisWorkbook.Worksheets("Pivot").UsedRange.Rows.Count
country = ThisWorkbook.Worksheets("Pivot").Cells(i, 7).Value
agents = ThisWorkbook.Worksheets("Pivot").Cells(i, 10).Value

rngSource.AutoFilter Field:=16, Criteria1:=country, Operator:=xlFilterValues
rngSource.AutoFilter Field:=25, Criteria1:="3", Operator:=xlFilterValues
rngSource.AutoFilter Field:=26, Criteria1:="No", Operator:=xlFilterValues
rngSource.AutoFilter Field:=23, Criteria1:="HR services", Operator:=xlFilterValues

rngSource.Sort Key1:=rngSource.Columns(27), Order1:=xlAscending, Header:=xlYes

On Error Resume Next
Set rngVisible = rngSource.Offset(1, 0).Resize(rngSource.Rows.Count - 1).Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set copyDestination = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
If copyDestination.Row < 3 Then

Set copyDestination = wsDest.Range("A3")
End If

For counter = 1 To agents
If counter <= rngVisible.Rows.Count Then
rngVisible.Cells(counter).Copy copyDestination
Set copyDestination = copyDestination.Offset(1, 0)
End If
Next counter

wsSource.AutoFilterMode = False

Next i


'Specialits Loop
For i = 6 To ThisWorkbook.Worksheets("Pivot").UsedRange.Rows.Count
country = ThisWorkbook.Worksheets("Pivot").Cells(i, 7).Value
specialists = ThisWorkbook.Worksheets("Pivot").Cells(i, 11).Value

rngSource.AutoFilter Field:=16, Criteria1:=country, Operator:=xlFilterValues
rngSource.AutoFilter Field:=25, Criteria1:="4", Operator:=xlFilterValues
rngSource.AutoFilter Field:=26, Criteria1:="No", Operator:=xlFilterValues
rngSource.AutoFilter Field:=23, Criteria1:="HR services", Operator:=xlFilterValues

rngSource.Sort Key1:=rngSource.Columns(27), Order1:=xlAscending, Header:=xlYes

On Error Resume Next
Set rngVisible = rngSource.Offset(1, 0).Resize(rngSource.Rows.Count - 1).Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set copyDestination = wsDestS.Cells(wsDestS.Rows.Count, "A").End(xlUp).Offset(1, 0)
If copyDestination.Row < 3 Then

Set copyDestination = wsDestS.Range("A3")
End If

For counter = 1 To specialists
If counter <= rngVisible.Rows.Count Then
rngVisible.Cells(counter).Copy copyDestination
Set copyDestination = copyDestination.Offset(1, 0)
End If
Next counter

wsSource.AutoFilterMode = False

Next i


'Newcomers Loop
rngSource.AutoFilter Field:=26, Criteria1:="Yes", Operator:=xlFilterValues
rngSource.AutoFilter Field:=23, Criteria1:="HR services", Operator:=xlFilterValues

On Error Resume Next
Set rngVisible = rngSource.Columns(1).Offset(1, 0).Resize(rngSource.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set copyDestination = wsDestN.Cells(wsDestN.Rows.Count, "A").End(xlUp).Offset(1, 0)
If copyDestination.Row < 3 Then
Set copyDestination = wsDestN.Range("A3")
End If

For counter = 1 To rngVisible.Rows.Count
rngVisible.Cells(counter).Copy copyDestination
Set copyDestination = copyDestination.Offset(1, 0)
Next counter

wsSource.ShowAllData


'Specialist Doublecheck Loop
lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
Set rngSpecialist = wsDest.Range("A2:U" & lastRow)

For i = 6 To ThisWorkbook.Worksheets("Pivot").UsedRange.Rows.Count
country = ThisWorkbook.Worksheets("Pivot").Cells(i, 7).Value
specialist = ThisWorkbook.Worksheets("Pivot").Cells(i, 12).Value

rngSpecialist.AutoFilter Field:=4, Criteria1:=country, Operator:=xlFilterValues

rngSpecialist.Sort Key1:=rngSpecialist.Columns(21), Order1:=xlAscending, Header:=xlYes

On Error Resume Next
Set rngVisible = rngSpecialist.Offset(1, 0).Resize(rngSpecialist.Rows.Count - 1).Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

For counter = 1 To specialist

Set celltoTypeY = rngVisible.Cells(counter, 15)

celltoTypeY.Value = "Y"

Next counter

Next i

wsDest.AutoFilterMode = False


'Clean up
If wsSource.FilterMode Then
wsSource.ShowAllData
End If
Set rngSource = Nothing
Set rngVisible = Nothing

MsgBox "Task is complete!", vbInformation

End Sub

 

[kevin9999]

Thank you for sharing your file - at least part of it. The file you shared has only one sheet (Case data report) which is the source data sheet, but your code refers in several places to the "Pivot" sheet. Is it possible to share your file with all sheets intact?

 

[Alcalore]

Thank you for the quick reply, please find the intact file:

Case data report v8.1.xlsm

Shared with Dropbox

www.dropbox.com

 

[kevin9999]

I'm about to switch off for tonight, but could I ask you to try the following code on a copy of your workbook & let me know how much of it achieves your goals - and how much needs to be amended.

Option Explicit
Sub Filter_Sort_Copy_V2()
    Application.ScreenUpdating = False
    Dim wsSrc As Worksheet, wsPiv As Worksheet
    Dim wsDestA As Worksheet, wsDestS As Worksheet, wsDestN As Worksheet
    
    Set wsSrc = Worksheets("Case data report")
    Set wsPiv = Worksheets("Pivot")
    Set wsDestA = Worksheets("Final Report Agents")
    Set wsDestS = Worksheets("Final Report Specialists")
    Set wsDestN = Worksheets("Final Report Newcomers")
    
    Dim LRow As Long, rng As Range
    LRow = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = wsSrc.Range("A2:AA" & LRow)
    
    'Set the filters & copy to destination sheets
    If wsSrc.AutoFilterMode Then wsSrc.AutoFilter.ShowAllData
    
    'Agents
    With rng
        .AutoFilter 23, "HR services"
        .AutoFilter 25, 3
        .AutoFilter 26, "No"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsDestA.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
    
    'Specialists
    With rng
        .AutoFilter 23, "HR services"
        .AutoFilter 25, 4
        .AutoFilter 26, "No"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsDestS.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
    
    'Newcomers
    With rng
        .AutoFilter 23, "HR services"
        .AutoFilter 26, "Yes"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsDestN.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    End With
    wsSrc.AutoFilter.ShowAllData
    Application.ScreenUpdating = False
End Sub

 

[Alcalore]

Thank you for looking into this!
The code provided by you seems to be filtering out the data correctly for each DestinationWS, however I only require the data from column A - the ID to be copied.
It also seems the random element is missing in the formula provided (sorting in column AA)
The PivotWS contains a table that contain information on the number of visible cells (for Agents/Specialists) for each country are to be copied into the DestinationWS.
Example:

For Austria it is 1visible cell from column A to be copied into Final Report Agents WS
For Belgium it is 10visible cells into Final Report Agents WS and 1visible cell into Final Report Specialists WS

 

[Alcalore]

I'm about to switch off for tonight, but could I ask you to try the following code on a copy of your workbook & let me know how much of it achieves your goals - and how much needs to be amended.

Option Explicit
Sub Filter_Sort_Copy_V2()
    Application.ScreenUpdating = False
    Dim wsSrc As Worksheet, wsPiv As Worksheet
    Dim wsDestA As Worksheet, wsDestS As Worksheet, wsDestN As Worksheet
  
    Set wsSrc = Worksheets("Case data report")
    Set wsPiv = Worksheets("Pivot")
    Set wsDestA = Worksheets("Final Report Agents")
    Set wsDestS = Worksheets("Final Report Specialists")
    Set wsDestN = Worksheets("Final Report Newcomers")
  
    Dim LRow As Long, rng As Range
    LRow = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = wsSrc.Range("A2:AA" & LRow)
  
    'Set the filters & copy to destination sheets
    If wsSrc.AutoFilterMode Then wsSrc.AutoFilter.ShowAllData
  
    'Agents
    With rng
        .AutoFilter 23, "HR services"
        .AutoFilter 25, 3
        .AutoFilter 26, "No"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsDestA.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
  
    'Specialists
    With rng
        .AutoFilter 23, "HR services"
        .AutoFilter 25, 4
        .AutoFilter 26, "No"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsDestS.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
  
    'Newcomers
    With rng
        .AutoFilter 23, "HR services"
        .AutoFilter 26, "Yes"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsDestN.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    End With
    wsSrc.AutoFilter.ShowAllData
    Application.ScreenUpdating = False
End Sub

I am currently working on an alternative, that seems to be working as I intended. It is a workaround but hey, as long as it works, right?
I did use part of the code provided by you to make the Autofilter part less of a hassle so thank you for that and I did come up with the idea of this workaround after checking your code so MANY THANKS

Sub Filter_Sort_Copy_V2()
Dim wsSource As Worksheet, wsDestA As Worksheet, wsDestS As Worksheet, wsDestN As Worksheet, wsHelper As Worksheet, wsPivot As Worksheet
Dim lastRowSource As Long, lastRowHelper As Long, i As Long
Dim rngSource As Range, rngCopy As Range, rngDestA As Range
Dim country As String, agents As String, specialitsts As String, specialist As String

Set wsSource = ThisWorkbook.Sheets("Case data report")
Set wsDestA = ThisWorkbook.Sheets("Final Report Agents")
Set wsDestS = ThisWorkbook.Sheets("Final Report Specialists")
Set wsDestN = ThisWorkbook.Sheets("Final Report Newcomers")
Set wsHelper = ThisWorkbook.Sheets("Helper Sheet")
Set wsPivot = ThisWorkbook.Sheets("Pivot")

lastRowSource = wsSource.Cells(Rows.Count, "A").End(xlUp).Row
Set rngSource = wsSource.Range("A2:AB" & lastRowSource)

If wsSource.AutoFilterMode Then wsSource.AutoFilter.ShowAllData

'Agents
For i = 6 To wsPivot.UsedRange.Rows.Count
    country = wsPivot.Cells(i, 7).Value
    agents = wsPivot.Cells(i, 10).Value
   
    If agents = 0 Then
        GoTo NextIteration
    End If
   
    With rngSource
        .AutoFilter 16, country
        .AutoFilter 25, 3
        .AutoFilter 26, "No"
        .AutoFilter 28, "Yes"
        .Offset(1).Resize(.Rows.Count - 1).Copy wsHelper.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        .AutoFilter
    End With
   
    lastRowHelper = wsHelper.Cells(Rows.Count, "A").End(xlUp).Row
   
    If agents = 1 Then
        Set rngCopy = wsHelper.Range("A3")
    Else
        Set rngCopy = wsHelper.Range("A3").Resize(agents)
    End If
   
    Set rngDestA = wsDestA.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
       
    If rngDestA.Row < 3 Then
        Set rngDestA = wsDestA.Range("A3")
    End If
       
    rngCopy.Copy rngDestA
       
    wsHelper.Range("A3:AB" & lastRowHelper).ClearContents

NextIteration:
Next i

MsgBox "Task has been completed!", vbInformation

End Sub

 

[kevin9999]

Glad to hear you got it sorted, well done

 

[Peter_SSs]

@Alcalore
When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block below has more details. I have added the tags for you this time in post #8.