VBA Loop Lookup of every nth (eg. every 3rd) match of an item

[Oraekene]

Hi. Good day. Grateful for all the help i've received on this site so far. Here again cap in hand seeking help.

I would like a vb script to loop through a range of values and find every nth eg. Every 3rd occurence of that value and copy and paste the single row of values in the next empty row in another range

Eg. I have customer data of 50 purchases made by 4 customers eg. A B C & D. Each purchase is a row of values showing date of purchase, item of purchase, price etc. I'd like to find every 3rd purchase A made (so her 3rd, 6th, 9th, 12th etc) and copy the row of data (date, item etc) to another range, then repeat for B, then repeat for C and D.

Would be grateful for any help on this. Attached is the sample sheet Sample Sheet

 

[Trebor76]

Hi Oraekene,

My following macro produces an extra record for "martin" from Row 38 but I think it's oversight on your side not the macro itself:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim lngSrcRow As Long, lngRowTo As Long, i As Long, j As Long
    Dim dictNames As Object
    Dim rngCell As Range, rngRqdData As Range
    Dim strName As String
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the data. Change to suit.
    lngRowTo = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Set dictNames = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    
    For lngSrcRow = 2 To lngRowTo
        strName = wsSrc.Range("A" & lngSrcRow)
        If Not dictNames.Exists(strName) And Application.WorksheetFunction.CountIf(wsSrc.Range("A2:A" & lngRowTo), strName) >= 3 Then
            i = i + 1: j = 0
            dictNames.Add strName, i
            For Each rngCell In wsSrc.Range("A2:A" & lngRowTo)
                If strName = CStr(rngCell) Then
                    j = j + 1
                    If (j Mod 3) = 0 Then
                        If rngRqdData Is Nothing Then
                            Set rngRqdData = wsSrc.Range("A" & rngCell.Row & ":E" & rngCell.Row)
                        Else
                            Set rngRqdData = Union(rngRqdData, wsSrc.Range("A" & rngCell.Row & ":E" & rngCell.Row))
                        End If
                    End If
                End If
            Next rngCell
        End If
    Next lngSrcRow
    
    rngRqdData.Copy Destination:=wsSrc.Range("M2")
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Peter_SSs]

I'd like to find every 3rd purchase A made (so her 3rd, 6th, 9th, 12th etc) and copy the row of data (date, item etc) to another range, then repeat for B, then repeat for C and D.

If your sample workbook contains your expected results, then you haven't processed the data in the order mentioned above. Here is a non-looping option to produce the sample results (with adjustment already mentioned by Robert). If you want the results grouped by customer (sorted alphabetically) then uncomment the Sort line near the end of the code.

Sub EveryNth()
  Dim cols As Long
  Dim rDel As Range
  
  Const N As Long = 3 'That is, keep every 3rd
  
  Application.ScreenUpdating = False
  Range("A1").CurrentRegion.Copy Destination:=Range("M1")
  With Range("M1").CurrentRegion
    cols = .Columns.Count
    With .Resize(, cols + 1)
      .Columns(cols + 1).FormulaR1C1 = Replace("=mod(countif(R1C[-#]:RC[-#],RC[-#])," & N & ")", "#", cols)
      .AutoFilter Field:=cols + 1, Criteria1:=">0"
      Set rDel = .Offset(1).SpecialCells(xlVisible)
      ActiveSheet.AutoFilterMode = False
      rDel.Delete Shift:=xlUp
      .Columns(cols + 1).ClearContents
'      .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[Oraekene]

Hi Oraekene,

My following macro produces an extra record for "martin" from Row 38 but I think it's oversight on your side not the macro itself:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim lngSrcRow As Long, lngRowTo As Long, i As Long, j As Long
    Dim dictNames As Object
    Dim rngCell As Range, rngRqdData As Range
    Dim strName As String
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the data. Change to suit.
    lngRowTo = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Set dictNames = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
   
    For lngSrcRow = 2 To lngRowTo
        strName = wsSrc.Range("A" & lngSrcRow)
        If Not dictNames.Exists(strName) And Application.WorksheetFunction.CountIf(wsSrc.Range("A2:A" & lngRowTo), strName) >= 3 Then
            i = i + 1: j = 0
            dictNames.Add strName, i
            For Each rngCell In wsSrc.Range("A2:A" & lngRowTo)
                If strName = CStr(rngCell) Then
                    j = j + 1
                    If (j Mod 3) = 0 Then
                        If rngRqdData Is Nothing Then
                            Set rngRqdData = wsSrc.Range("A" & rngCell.Row & ":E" & rngCell.Row)
                        Else
                            Set rngRqdData = Union(rngRqdData, wsSrc.Range("A" & rngCell.Row & ":E" & rngCell.Row))
                        End If
                    End If
                End If
            Next rngCell
        End If
    Next lngSrcRow
   
    rngRqdData.Copy Destination:=wsSrc.Range("M2")
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Thank you for this! And happy thanksgiving! Hope it was fun. Nigerian here so we don't celebrate it, but i know its a big big deal so hope the weekend has been fun. Will try this out and get back to you

 

[Oraekene]

If your sample workbook contains your expected results, then you haven't processed the data in the order mentioned above. Here is a non-looping option to produce the sample results (with adjustment already mentioned by Robert). If you want the results grouped by customer (sorted alphabetically) then uncomment the Sort line near the end of the code.

Sub EveryNth()
  Dim cols As Long
  Dim rDel As Range
 
  Const N As Long = 3 'That is, keep every 3rd
 
  Application.ScreenUpdating = False
  Range("A1").CurrentRegion.Copy Destination:=Range("M1")
  With Range("M1").CurrentRegion
    cols = .Columns.Count
    With .Resize(, cols + 1)
      .Columns(cols + 1).FormulaR1C1 = Replace("=mod(countif(R1C[-#]:RC[-#],RC[-#])," & N & ")", "#", cols)
      .AutoFilter Field:=cols + 1, Criteria1:=">0"
      Set rDel = .Offset(1).SpecialCells(xlVisible)
      ActiveSheet.AutoFilterMode = False
      rDel.Delete Shift:=xlUp
      .Columns(cols + 1).ClearContents
'      .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
    End With
  End With
  Application.ScreenUpdating = True
End Sub

You always come through! Thank you! Don't know if you're American but if you are Happy Thanksgiving! Hope the weekend has been fun

Yes yes yes you are right, its not in the order as i initially explained it, grouped by customer. The way i laid it in the samples sheet is exactly how i want it, and the reason is i'd like to sort all purchases by date and time from the earliest to the latest. Thank you for noticing the oversight. I'll try this out and get back to you on this

 

[Peter_SSs]

You're welcome.

Don't know if you're American

I'm not. If you hover over my avatar or user name on the left of this window you can see.

 

[Oraekene]

They both work excellently well! Thank you! I can only select one right answer so i'll choose it arbitrarily but they both work perfectly well, thank you!

 

[Trebor76]

They both work excellently well! Thank you! I can only select one right answer so i'll choose it arbitrarily but they both work perfectly well, thank you!

I see you've marked my suggested macro as the solution. I personally would have chosen Peter's as his method does not loop and will therefore be much faster on larger datasets

 

[Oraekene]

I see you've marked my suggested macro as the solution. I personally would have chosen Peter's as his method does not loop and will therefore be much faster on larger datasets

I did because i had no idea how to decide and yours was first so i just went for it. But yeah you're very right, i'll mark his now

 

[Oraekene]

Hi. I'd like some help. Went back and realised i need to change the filter criteria. Its still every 3rd mention but now it would be based on two criteria: the name of the item and a 3rd unique mention from a account. I'll drop an example below to explain

ACCOUNT - PROJECT - TIMEDATE - Rate (acct) - Rate(proj) - Rate(mention from that account)
10xe001 - jagudam - 12/03/22 - A - 1 - i
10xe001 - jagudam - 12/03/22 - A - 1 - ii
10xe002 - mandela - 12/03/22 - B - 2 - i
10xe002 - nsobu - 13/0/22 - B - 3 - i
10xe001 - mandela - 13/03/22 - A - 2 - i
10xe003 - mandela - 14/03/22 - C - 2 - i
10xe004 - mandela - 14/03/22 - D - 1 - i
10xe002 - caricature - 14/03/22 - B - 4 - i
10xe002 - nsobu - 14/03/22 - B - 3 - ii
10xe002 - deeper life - 16/03/22 - B - 5 - i
10xe001 - deeper life - 17/03/22 - A - 5 - i
10xe001 - jagudam - 17/03/22 - A - 1 - iii
10xe004 - jagudam - 18/03/22 - D - 1 - ii
10xe004 - jagudam - 18/03/22 - D - 1 - iii
10xe005 - jagudam - 18/03/22 - E - 1 - i
10xe002 - jagudam - 18/03/22 - B - 1 - i
10xe003 - mandela - 18/03/22 - C - 2 - ii
10xe003 - nsobu - 18/03/22 - C - 3 - i
10xe003 - mandela - 18/03/22 - C - 2 - iii
10xe003 - mandela - 18/03/22 - C - 2 - iv
10xe005 - mandela - 18/03/22 - E - 2 - i
10xe003 - caricature - 19/03/22 - C - 4 - i
10xe001 - nsobu - 19/03/22 - A - 3 - i
10xe001 - deeper life - 19/03/22 - A - 5 - ii
10xe004 - deeper life - 20/03/22 - D - 5 - i
10xe004 - jagudam - 22/03/22 - D - 1 - iii
10xe005 - jagudam - 22/03/22 - E - 1 - ii
10xe003 - jagudam - 22/03/22 - C - 1 - i
10xe004 - jagudam - 23/03/22 - D - 1 - iv
10xe002 - jagudam - 24/03/22 - B - 1 - ii
10xe001 - jagudam - 24/03/22 - A - 1 - iv
10xe001 - mandela - 25/03/22 - A - 2 - ii
10xe001 - nsobu - 25/03/22 - A - 3 - ii
10xe001 - mandela - 25/03/22 - A - 2 - iii
10xe002 - mandela - 25/03/22 - B - 2 - i
10xe002 - mandela - 25/03/22 - B - 2 - ii
10xe004 - caricature - 25/03/22 - D - 4 - i
10xe005 - nsobu - 25/03/22 - E - 3 - i
10xe005 - deeper life - 25/03/22 - E - 5 - i
10xe005 - deeper life - 26/03/22 - E - 5 - ii
10xe005 - jagudam - 27/03/22 - E - 1 - iii
10xe001 - jagudam - 27/03/22 - A - 1 - v
10xe005 - jagudam - 28/03/22 - E - 1 - iv

The emojis indicate a highlighted result, each emoji type for a different project. Here is the key

Jagudam - 1 -
Mandela - 2 -
Nsobu - 3 -
Caricature - 4 -
Deeper life - 5 -

*C-2-i where the 'C' are the account numbers, '2' are the projects, and 'i' is the sequence of times the same account appears with the same project

Above, when a project appears with a third unique account, it is selected. So for example the first selection: account 001 appears with mandela, then account 002 then when account 003 appears with mandela, that entry is selected, and the filter resets itself and starts acounting again. With Jagudam for eg, account 001 appeared with it multiple time, but it wasn't until the third unique account, account 005, that the selection was made

Can this be achieved?