auto adjust row and copy format

[bluepenink]

Hello

below is my macro, but when it transfers the data into the worksheets, it's not copying the format of the 'main' worksheet it copies from.
i.e. columns A & B are 0.75 width etc and etc, so can someone pls help me apply that into my formula?

pls and thxs

Option Explicit
Sub FilterCities()
  'consolidate employee by branch - hhaque
    Dim myCell As Range
    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim TempWks As Worksheet
    Dim rsp As Integer
    Dim i As Long
    'include bottom most header row
    Const TopLeftCellOfDataBase As String = "A6"
    'what column has your key values
    Const KeyColumn As String = "C"
    'where's your data
    Set DataBaseWks = Worksheets("Main")
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
    
    rsp = MsgBox("Include headings?", vbYesNo, "Headings")
Application.ScreenUpdating = False
    Set TempWks = Worksheets.Add
    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                            .Cells.SpecialCells(xlCellTypeLastCell))
    End With
    'rebuild the List
    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=TempWks.Range("A1"), _
            Unique:=True
        'Add the heading to the criteria area
        TempWks.Range("D1").Value = _
            .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With
    With TempWks
        Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With
    'check for individual City worksheets
    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox "Please rename: " & wks.Name
                Err.Clear
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If
        If rsp = 6 Then
          DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
        End If
        
        'change the criteria in the Criteria range
        TempWks.Range("D1").Value = "Branch"
        TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)
        'transfer data to individual City worksheets
        If rsp = 6 Then
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1").Offset(i, 0), _
              Unique:=False
        Else
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1"), _
              Unique:=False
        End If
    Next myCell
    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
    MsgBox "Employees have been sorted by Branch"
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)