Copy all rows with common value in a column to new file [closed]

Like example:

Option Explicit

Sub SplitDataByColumnI()
    Dim wsDest      As Worksheet
    Dim i           As Long, key

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook.Worksheets("Sheet1")   ' This worksheet may have a different name for you, please replace it with your name

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        If lastRow < 2 Then
            MsgBox "No data available for distribution!", vbExclamation
            Exit Sub
        End If

        Dim headers As Variant
        headers = .Range("A1:I1").Value

        Dim arr     As Variant
        arr = .Range("A2:I" & lastRow).Value
    End With

    Dim dict        As Object
    Set dict = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(arr, 1)
        key = Trim(CStr(arr(i, 9)))

        If key <> "" Then

            If Not dict.exists(key) Then
                dict.Add key, New Collection
            End If

            dict(key).Add Application.Index(arr, i)
        End If

    Next i

    For Each key In dict.keys

        On Error Resume Next
        Set wsDest = ThisWorkbook.Worksheets(key)
        On Error GoTo 0

        If wsDest Is Nothing Then
            Set wsDest = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            wsDest.Name = key
        Else
            wsDest.UsedRange.Clear
        End If

        wsDest.Range("A1:I1").Value = headers

        Dim tempArr()
        ReDim tempArr(1 To dict(key).Count, 1 To 9)

        Dim j       As Long
        
        For i = 1 To dict(key).Count
            
            For j = 1 To 9
                tempArr(i, j) = dict(key)(i)(j)
            Next j
        
        Next i

        wsDest.Range("A2").Resize(UBound(tempArr, 1), UBound(tempArr, 2)).Value = tempArr
        Set wsDest = Nothing
    Next key

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "DONE!", vbInformation
End Sub

Apply a filter for each city in turn and copy visible cells to a new sheet in existing workbook.

Sub SplitData()

    Dim wb As Workbook, ws As Worksheet, wsAll As Worksheet
    Dim rng As Range, bExists As Boolean
    Dim dictCity As Object
    Dim k, r As Long, lastrow As Long, n As Long
    
    Set wb = ThisWorkbook
    Set wsAll = wb.Sheets("Sheet1")
    Set dictCity = CreateObject("Scripting.Dictionary")
   
    With wsAll
        lastrow = .Cells(.Rows.Count, "I").End(xlUp).Row ' City
        Set rng = .Range("A1:I" & lastrow)
        
        ' determine unique city names
        For r = 2 To lastrow
            k = .Cells(r, "I")
            dictCity(k) = 1
            bExists = False
            
            ' clear if existing sheet
            bExists = False
            For Each ws In wb.Sheets
                If ws.Name = k Then
                    ws.Cells.Clear
                    bExists = True
                    Exit For
                End If
            Next
             
          ' create new sheet if not existing
          If Not bExists Then
             n = wb.Sheets.Count
             Set ws = wb.Worksheets.Add(after:=wb.Sheets(n))
             ws.Name = k
          End If
       Next
    End With
       
    ' filter by city and copy
    Application.ScreenUpdating = False
    rng.AutoFilter
    For Each k In dictCity.keys
        rng.AutoFilter 9, k ' col I
        Set ws = wb.Sheets(k)
        rng.Copy ws.Range("A1")
    Next
    rng.AutoFilter
    Application.ScreenUpdating = True
    
    MsgBox dictCity.Count & " cities found", vbInformation
   
End Sub