Filtering by certain column...macro

[bluepenink]

hello

i have the following macro that creates worksheets from worksheet called "main" based on column E (Branch).

it takes the data from sheet "main" and creates the # of worksheets based on the # of cities and transfers the corresponding data in the rows with it (copying the header etc) with it.

here is my code

Option Explicit
Sub FilterCities()
'consolidated employees by branch
    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
    Dim colWidths(16) As Variant
    Dim cwlc As Long    ' column width loop counter
    'include bottom most header row
    Const TopLeftCellOfDataBase As String = "A6"
    'what column has your key values
    Const KeyColumn As String = "E"
    'where's your data
    Set DataBaseWks = Worksheets("Main")
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
    
    With DataBaseWks
        For cwlc = 1 To 16
            colWidths(cwlc) = .Columns(cwlc).ColumnWidth
        Next cwlc
    End With
    rsp = MsgBox("Include headings?", vbYesNo, "Filter by branch")
    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
    With wks
        For cwlc = 1 To 16
            .Columns(cwlc).ColumnWidth = colWidths(cwlc)
        Next cwlc
        
    ActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines
    
' new code
       With .PageSetup
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = "&""Arial,Regular""&8DRAFT"
            .LeftFooter = "&""Arial,Regular""&8&F"
            .CenterFooter = "&""Arial,Regular""&8Confidential"
            .RightFooter = "&""Arial,Regular""&8Page: &P of &N"
            .LeftMargin = Application.InchesToPoints(0.17)
            .RightMargin = Application.InchesToPoints(0.17)
            .TopMargin = Application.InchesToPoints(0.24)
            .BottomMargin = Application.InchesToPoints(0.26)
            .HeaderMargin = Application.InchesToPoints(0.17)
            .FooterMargin = Application.InchesToPoints(0.16)
            .Orientation = xlPortrait
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = False
        End With
' end of new code
    End With
    Next myCell
    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Employees filtered by branch complete"
End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

for some reason and i cant seem to figure out why....

when i change the column to "H" (Position) in:

    'what column has your key values
    Const KeyColumn As String = "E"

everything gets copied to a new worksheet excep for the data points (the employee name, branch they are from, when they started etc)....the header columns gets transfered over and the new worksheet are created by column "H".....

i know itll prob take someone real quick to figure this out, but ive been at this for a while and yeah. i really appreciate the input!!!

 

[GlennUK]

What do you mean by

everything gets copied to a new worksheet excep for the data points

... what's everything? Anyway, was column E the Branch by any chance? If you are changing to column H, shouldn't you be filtering on Position instead of Branch, if that is the case?