Untitled

Sub SeparateTableIntoWorkbooksByCriteria()

Dim ws As Worksheet
Dim tbl As ListObject
Dim rng As Range
Dim wb As Workbook
Dim lRow As Long
Dim i As Long
Dim criteria As String

'Set the worksheet and table variables
Set ws = ThisWorkbook.Sheets("Sheet1")
Set tbl = ws.ListObjects("Table1")

'Set the criteria for separating the table
criteria = "Column1"

'Find the last row of the table
lRow = tbl.Range.Rows.Count

'Loop through each row in the table
For i = 1 To lRow
    'Set the range variable to the current row
    Set rng = tbl.ListRows(i).Range
    'Check if the value in the criteria column matches London
    If rng.Cells(1, criteria).Value = "London" Then
        'Create a new workbook
        Set wb = Workbooks.Add
        'Copy the current row to the new workbook
        rng.Copy wb.Sheets(1).Range("A1")
        'Save the new workbook with the name "London Row i"
        wb.SaveAs ThisWorkbook.Path & "\London Row " & i & ".xlsx"
    'Check if the value in the criteria column matches Warsaw
    ElseIf rng.Cells(1, criteria).Value = "Warsaw" Then
        'Create a new workbook
        Set wb = Workbooks.Add
        'Copy the current row to the new workbook
        rng.Copy wb.Sheets(1).Range("A1")
        'Save the new workbook with the name "Warsaw Row i"
        wb.SaveAs ThisWorkbook.Path & "\Warsaw Row " & i & ".xlsx"
    'Check if the value in the criteria column matches New York
    ElseIf rng.Cells(1, criteria).Value = "New York" Then
        'Create a new workbook
        Set wb = Workbooks.Add
        'Copy the current row to the new workbook
        rng.Copy wb.Sheets(1).Range("A1")
        'Save the new workbook with the name "New York Row i"
        wb.SaveAs ThisWorkbook.Path & "\New York Row " & i & ".xlsx"
    End If
Next i

End Sub