VBA to move predifined number of records to a new sheet

[Kpersen]

Good day everyone.

I have a challenging question on VBA. I have a table that contains approximately 3000 rows of customers (customer name in column F) that are allocated to about 20 different location codes in the US (location code is column B) Each week I need to move a predefined number of customers for each location code from this table to a new sheet. The number of customers to be moved for each location is predefined in a separate table. I must make sure that once the predefined number of customers for each location code is moved they are no longer in the original table. Additionally I must ensure that if at any time the number of predefined records is not available to move the macro will move what is left and skip the location if there are no customers available at all. I have look in the forum but found nothing that would work. Does anyone have any suggestions?

 

[DanteAmor]

This works perfectly.
Thank you ever so much for your help - I really appreciate it.

I'm glad to help you. Thanks for the feedback.

 

[Kpersen]

One last request:
Is there a way I can set a predefined number of records for each location to move over to the new list instead it always being 10 or whatever is available?
Not all locations require 10 records but rather a number that varies from location to location. I would still like to keep the part that takes whatever is left if the predefined number of records is not available?

 

[DanteAmor]

One last request:
Is there a way I can set a predefined number of records for each location to move over to the new list instead it always being 10 or whatever is available?
Not all locations require 10 records but rather a number that varies from location to location. I would still like to keep the part that takes whatever is left if the predefined number of records is not available?

I asked that question in post #3 and #5 , but I ask you again, where do you plan to put how many records correspond to each location? Do you plan to put it on a sheet?

 

[Kpersen]

I have a hidden sheet in the workbook where the location codes and the number of records (contacts) are organized in a table.
The sheet is called "Weekly Contact Count" the table is named "CC".
Column A= location code and columns B= number of records.
The header is row 1:

Location # Contacts
ATL 10
BOS 5
CHS 5

and so on.


Thanks again for al your support - I am fairly new to VBA and I don't fully understand the different components yet.

 

[DanteAmor]

I have a hidden sheet in the workbook where the location codes and the number of records (contacts) are organized in a table.
The sheet is called "Weekly Contact Count" the table is named "CC".
Column A= location code and columns B= number of records.
The header is row 1:

Location # Contacts
ATL 10
BOS 5
CHS 5

and so on.


Thanks again for al your support - I am fairly new to VBA and I don't fully understand the different components yet.

Is it necessary for the data to be in a table?

 

[Kpersen]

Is it necessary for the data to be in a table?

No, it can be a range if needed.

Only the CC is table ad the range is A2 to B38 including header.
All other sheets are not defined as tables.

 

[DanteAmor]

Then, please you can put it in a range.

 

[Kpersen]

OK the range is A2:B38 in sheet "Weekly Contact Count"

 

[DanteAmor]

Try this

Sub DAM_Select_Location_2()
  Dim sh As Worksheet, s2 As Worksheet
  Dim c As Range, r As Range, n As Long, tope As Variant, wRow As Long
  
  Application.ScreenUpdating = False
  Set sh = Sheets("Master List")
  Set s2 = Sheets("Weekly Contact Count")
  For Each c In s2.Range("A2", s2.Range("A" & Rows.Count).End(xlUp))
    tope = c.Offset(, 1)
    sh.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:=c
    n = 0
    For Each r In sh.ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
      wRow = r.Row
      n = n + 1
      If n = tope Then Exit For
    Next
    sh.Range("A2:L" & wRow).SpecialCells(xlCellTypeVisible).Copy Sheets("New List").Range("A" & Rows.Count).End(xlUp)(2)
    sh.Range("A2:L" & wRow).EntireRow.Delete
   Next
  sh.ShowAllData
  Application.ScreenUpdating = True
  MsgBox "End"
End Sub

 

[Kpersen]

Good morning Dante

Thanks again for taking the challenge and the time to help me - I am ever so grateful.

I tried running it and it did have a couple of issues:

When the macro comes to the pieces that says: "sh.Range("A2:L" & wRow).EntireRow.Delete" - it stops.
I believe this is where it would delete the records it copied to the new list ?

Ken