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?

 

[Kpersen]

I have pieced together a few first steps where I have selected a value (TUS) and want to copy the first visible 10 rows and then paste them into the sheet named "New List)
The macro works as far as making the correct selection and cutting the visible cells only, BUT I cannot get it to paste into my sheet at the last empty row in column A.
Any suggestions:

Sub Selection()
' Selection Macro

ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:= _
"TUS"
Range("A2").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Height <> 0
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Resize(10, 12).SpecialCells(xlCellTypeVisible).Cut

 

[DanteAmor]

I have pieced together a few first steps where I have selected a value (TUS) and want to copy the first visible 10 rows and then paste them into the sheet named "New List)
The macro works as far as making the correct selection and cutting the visible cells only, BUT I cannot get it to paste into my sheet at the last empty row in column A.
Any suggestions:

Sub Selection()
' Selection Macro

ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:= _
"TUS"
Range("A2").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Height <> 0
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Resize(10, 12).SpecialCells(xlCellTypeVisible).Cut

Resizing in a filtered table does not work as when the data is not filtered.
In your case, if you want to select 10 records, you will probably select less than 10, because it will count 10 rows, including hidden ones, even if you indicate "SpecialCells(xlCellTypeVisible)".


Try the following:

Sub selection()
  Dim r As Range, n As Long
  ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:="TUS"
  For Each r In ActiveSheet.ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
    n = n + 1
    If n = 10 Then
      Range("A2:L" & r.Row).SpecialCells(xlCellTypeVisible).Copy Sheets("New").Range("A" & Rows.Count).End(xlUp)(2)
      Exit For
    End If
  Next
End Sub

The above works only for the "TUS" location, I suppose you want to do the same for all your locations.
Explain how and where you have your locations, to cycle with each location, filter the database, select the predefined number by location, copy and paste in the "new" sheet.

 

[Kpersen]

Thank you Dante for the suggestion. I tried it but it will only go as far as selecting the "TUS" value in the filter.
I was working on this over the weekend and pieced together another code that does work my problem with this one however is that it will not repeat the steps for the next location if I duplicate and change the location

Sheets("Master List").ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:= _
"ATL"
Range("A2").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Height <> 0
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Resize(10, 12).SpecialCells(xlCellTypeVisible).Cut
Sheets("New List").Select
Range("A1048576").End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste


Sheets("Master List").ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:= _
"BOS"
Sheets("Master List").Select
ActiveSheet.Range("A2").Select
ActiveCell.Offset(1, 0).Select (STOPS WORKING FROM HERE)
Do Until ActiveCell.Height <> 0
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Resize(10, 12).SpecialCells(xlCellTypeVisible).Cut
Sheets("New List").Select
Range("A1048576").End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Above show a working code for ATL station but if I insert another one and change "ATL" to for instance "BOS" it will no repeat. It goes as far as selecting "BOS" and cell "A2" and then it cannot figure out to select the first 10 visible cells and so on.

 

[DanteAmor]

As I had already mentioned, this form: ActiveCell.Resize(10, 12).SpecialCells(xlCellTypeVisible).Cut does not select the 10 visible ones, it can be with the code that I sent you in post #3 .

If you want, I help you adapt it. Answer the following:
Do you have a list of codes on any sheet?
There are always 10 records what you need?

 

[Kpersen]

There will not always be 10 records because the idea is to move 10 records from "Master List" to "New List" once weekly for each location (ATL, BOS, MIA etc.) until the "Master List" is exhausted. The "Master List" will then be replenished with new records. Towards the end of the month there might be less than 10 records for each location but I wanted to go with 10 every time and because it is the max.
Need to ensure that records are "cut" not "copied" as the same records may not be moved the following week. The last code I entered worked for the first location but when I copy and change the location code for the next one it stalls at the selection expansion.

 

[DanteAmor]

Again, this form: ActiveCell.Resize(10, 12).SpecialCells(xlCellTypeVisible).Cut does not select the 10 visible ones. Only if the data is sorted by code and filtered by the first code, it apparently works, but only gets the first 10.

Do you want 10 or the number of records you have if it is less than 10?

I understand you want Cut, but I put Copy for you to do the tests.

 

[Kpersen]

Hi Dante.
My apologies - I misunderstood your question. It would be great if the code would take whatever number of records are available for each of the locations but it would need to be a maximum of 10 though.

 

[DanteAmor]

Try this.

Check the name of your sheets
Cut's behavior is not the same as Copy.
So I will copy and then delete. With the Delete option delete the row, if you don't want to delete the row then change Delete to ClearContents.

Sub DAM_Select_Location()
  Dim r As Range, n As Long, sh As Worksheet, s2 As Worksheet, c As Range, ky As Variant, wRow As Long
  Application.ScreenUpdating = False
  Set sh = Sheets("[COLOR=#0000ff]Master List[/COLOR]")
  With CreateObject("scripting.dictionary")
     For Each c In sh.ListObjects("Table1").ListColumns(4).DataBodyRange
        .Item(c.Value) = Empty
     Next
     For Each ky In .Keys
        sh.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:=ky
        n = 0
        For Each r In sh.ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
          wRow = r.Row
          n = n + 1
          If n = 10 Then Exit For
        Next
        sh.Range("A2:L" & wRow).SpecialCells(xlCellTypeVisible).Copy Sheets("[COLOR=#0000ff]New List[/COLOR]").Range("A" & Rows.Count).End(xlUp)(2)
        sh.Range("A2:L" & wRow).EntireRow.[COLOR=#ff0000]Delete[/COLOR]
     Next ky
  End With
  sh.ShowAllData
  Application.ScreenUpdating = True
  MsgBox "End"
End Sub

 

[Kpersen]

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