Use VBA to copy unique rows to another spreadsheet if condition is met

I'm new to VBA and any help would be greatly appreciated!!

My office is coordinating applications for positions across the US. When people apply, they pick which two states they would be willing to work in. All application information is manually entered into Worksheet A, which has a lot of columns, but 5 important ones: Unique ID, First Name, Last Name, Preferred State1, Preferred State2. This worksheet gets updated daily.

I have 50 worksheets (one for each state in the US). I wrote VBA code to copy each row from Spreadsheet A into the 50 state worksheets when the state worksheet is created.

I need to copy the new information that is added to Spreadsheet A every day into the appropriate state spreadsheets. All applicants who picked a state need to go into the state worksheet (the state order of preference doesn't matter).

For example, today, Spreadsheet A could be:

ID	First Name	Last Name	State1	State2
111	Bob	Belcher	New Jersey	Alaska
222	Rose	Nylund	Minnesota	Florida
333	Beef	Tobin	Alaska	California

So the Alaska spreadsheet would have:

ID	First Name	Last Name
111	Bob	Belcher
333	Beef	Tobin

Tomorrow, Worksheet A could have new people added (IDs 444 and 555) and I would only want to add the new people who picked Alaska to the Alaska worksheet (ID 555 Colin Robinson).

ID	First Name	Last Name	State1	State2
111	Bob	Belcher	New Jersey	Alaska
222	Rose	Nylund	Minnesota	Florida
333	Beef	Tobin	Alaska	California
444	Charlie	Bucket	New York	Florida
555	Colin	Robinson	New York	Alaska

I was using this code based on unique IDs in Column A, but it doesn't account for the different states.

Sub Copy ()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheet4
Set sh2 = Sheet1
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("B2:B" & lr)
For Each c In rng
    If WorksheetFunction.CountIf(sh2.Range("B:B"), c.Value) = 0 Then
        sh2.Range("B" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)(2).Resize(1, 5) = c.Resize(1, 5).Value
    End If
Next
End Sub

Solution

Export Data to Multiple Worksheets

To avoid creating duplicates, I've added a 6th (sfrCol) flag column which will contain "Yes" (sFlag) in each row that was transferred. The code is just looking for any content, so you can use whatever value you like.
The code will first find the first available cell in this flag column to reference the range of data that was not transferred.
Then it will loop through the rows of this range and transfer (copy) the rows accordingly, creating new worksheets, if necessary, otherwise, appending the rows after the already written data.

Option Explicit

Sub ExportByCountry()
    
    ' Source
    Const sName As String = "A" ' Worksheet Name
    Const slrCol As Long = 1 ' Last Row Column
    Const sfrCol As Long = 6 ' Flag Column
    Const sFlag As String = "Yes"
    Dim stCols As Variant: stCols = VBA.Array(1, 2, 3) ' Transfer Columns
    Dim scCols As Variant: scCols = VBA.Array(4, 5) ' Country Columns
    ' Destination
    Const dfCol As Long = 1 ' First Column
    Const dfRow As Long = 1 ' First Row
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim stUpper As Long: stUpper = UBound(stCols)
    Dim scUpper As Long: scUpper = UBound(scCols)
    Dim dtCount As Long: dtCount = stUpper + 1
    Dim dHeaders As Variant: ReDim dHeaders(0 To stUpper)
    
    Dim srg As Range
    Dim srCount As Long
    Dim dt As Long
    
    With sws.Range("A1").CurrentRegion ' (with headers)
        ' Write headers to an array.
        For dt = 0 To stUpper
            dHeaders(dt) = .Cells(dt + 1).Value
        Next dt
        srCount = .Rows.Count
        ' Reference the source data range (no headers)
        Set srg = .Resize(srCount - 1).Offset(1)
    End With
     
    Dim sfCell As Range
    s
    ' Reference the first available cell in the flag column ('sfCell').
    With srg.Columns(sfrCol)
        Set sfCell = .Find("*", , xlFormulas, , , xlPrevious)
        If sfCell Is Nothing Then
            Set sfCell = .Cells(1)
        ElseIf sfCell.Row = srCount Then
            MsgBox "Data already transferred.", vbExclamation
            Exit Sub
        Else
            Set sfCell = sfCell.Offset(1)
        End If
    End With
    
    ' Reference the not flagged range ('srg').
    Set srg = srg.Resize(srCount - sfCell.Row + 1).Offset(sfCell.Row - 2)
    srCount = srg.Rows.Count
    
    ' Write the range to the source array ('sData').
    Dim sData As Variant: sData = srg.Value
    Dim dtData As Variant: ReDim dtData(0 To stUpper) ' Transfer Data Array
    
    Dim dws As Worksheet
    Dim drrg As Range ' Destination Row Range
    Dim sr As Long ' Source Row Counter
    Dim sc As Long ' Source Country Column Counter
    
    For sr = 1 To srCount
        For sc = 0 To scUpper
            ' Attempt to create a reference to the destination worksheet.
            On Error Resume Next
                Set dws = wb.Worksheets(sData(sr, scCols(sc)))
            On Error GoTo 0
            If dws Is Nothing Then ' worksheet doesn't exist
                ' Add a new worksheet, rename it and write the headers.
                Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                dws.Name = sData(sr, scCols(sc))
                dws.Cells(dfRow, dfCol).Resize(, dtCount).Value = dHeaders
            'Else ' worksheet exists; do nothing
            End If
            ' Write the values from the row ('sr') of the source array
            ' to the transfer data array.
            For dt = 0 To stUpper
                dtData(dt) = sData(sr, stCols(dt))
            Next dt
            ' Reference the first 'available' destination row range.
            With dws.Columns(dfCol)
                Set drrg = .Find("*", , xlFormulas, , , xlPrevious) _
                    .Offset(1).Resize(, dtCount)
            End With
            ' Write the values from the transfer data array
            ' to the destinaton row range.
            drrg.Value = dtData
            
            Set dws = Nothing
        Next sc
        ' Write the flag.
        srg.Cells(sr, sfrCol).Value = sFlag
    Next sr
    
    sws.Select
    'wb.Save
    
    MsgBox "Data transferred.", vbInformation
    
End Sub