Move rows to different excelfiles matching multiple cellvalues per file - excel

Question

I would like to be able to move the rows of a large-ish excel file into different excel files. Multiple matching cell values from a single column in the source file will need to be moved to each destination file. I would like to do this in an easily extensible way since there will be an increasing number of cell value and destination file pairs in the future.
In my current implementation I first move the rows to separate sheets, one for each destination file and later make separate files from each sheets, that part of the code works well and for brevity I have not included it in this question.
So far I have tried using the following for moving the rows to their respctive new worksheets, and it works but has made for lots of redundancies in the code. I have included a code sample using just one pair, "PRE Name1*" which goes in the sheet "Destfile1", in my current project I have the big code block repeated for every pair, which makes the project not very easy to work with. The first part of the pair, that matches the cell value is using wildcard matching since most of the values have common prefixes in their names.
Sub SplitOnCellvalues()
Dim xRg As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Source").UsedRange.Rows.Count
J = Worksheets("Destfile1").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Destfile1").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Source").Range("O1:O" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) Like "PRE Name1*" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Destfile1").Range("A" & J + 1)
xRg(K).EntireRow.Delete
K = K - 1
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I currently also have a separate sub that pre-creates the sheets so it is safe to assume they exist.
I have also tried to build a multidimensional array that I could iterate over instead, but I can't seem to find a good way to build the array that feels like it will scale well when the list of pairs grow larger.
To illustrate the list of matching cell values and destination sheets they need to be moved to looks similar to this
"PRE Name1*" "Destfile1111"
"PRE Name2*" "DestfileAAAA"
"PRE AAAAA*" "Destfile1111"
"PRE DDDDD*" "Destfile2222"
"PRE Name4*" "DestfileAAAA"
"PRE Name4*" "DestfileAAAA"
I am mostly looking for a way to do this with fairly clean and extensible code as this project will need to be amended with new pairs of cell values and destination files on at least a monthly basis for the foreseeable future.

Answer 1

This code should do what you want. It doesn't delete the source range though.
I haven't added the * wildcard to the end of each value. It gets added during the filter.
Option Explicit
Public Sub SplitOnCellValues()
Dim MatchesArray() As Variant
MatchesArray = Array("PRE Name1", "Destfile1111", _
"PRE Name2", "DestfileAAAA", _
"PRE AAAAABV", "Destfile1111", _
"ABC", "Destfile1234")
Dim SourceSheet As Worksheet
Set SourceSheet = ThisWorkbook.Worksheets("Source")
'Make sure the source sheet isn't filtered and set a range
'to the data including and excluding headers.
With SourceSheet
If .AutoFilterMode Then .AutoFilterMode = False
Dim SourceLastCell As Range
Set SourceLastCell = LastCell(SourceSheet)
Dim SourceRange As Range
Set SourceRange = .Range(.Cells(1, 1), SourceLastCell)
Dim SourceData As Range
Set SourceData = .Range(.Cells(2, 1), SourceLastCell)
End With
'Loop through the array and filter the source data.
'If data is found then copy the visible rows to the bottom of the required sheet.
Dim TargetLastCell As Range
Dim TargetSheet As Worksheet
Dim x As Long
For x = LBound(MatchesArray) To UBound(MatchesArray) Step 2
SourceRange.AutoFilter Field:=15, Criteria1:=MatchesArray(x) & "*"
If SourceRange.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
Set TargetSheet = ThisWorkbook.Worksheets(MatchesArray(x + 1))
Set TargetLastCell = LastCell(TargetSheet)
SourceData.SpecialCells(xlCellTypeVisible).Copy _
Destination:=TargetSheet.Cells(TargetLastCell.Row + 1, 1)
End If
Next x
End Sub
'Find the last cell on a sheet. Returns A1 if the sheet is empty.
Public Function LastCell(wrkSht As Worksheet) As Range
Dim LastCol As Long, LastRow As Long
On Error Resume Next
With wrkSht
LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
End With
If LastCol = 0 Then LastCol = 1
If LastRow = 0 Then LastRow = 1
Set LastCell = wrkSht.Cells(LastRow, LastCol)
On Error GoTo 0
End Function