macro to sort by city...not functioning

bluepenink

Well-known Member
Joined
Dec 21, 2010
Messages
585
Hi

my code is listed below:

Code:
Option Explicit
Sub FilterCities()
  'last edited March 18, 2004
    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 = "C4"
    'what column has your key values
    Const KeyColumn As String = "A"
    'where's your data
    Set DataBaseWks = Worksheets("Main")
    i = DataBaseWks.Range(TopLeftCellOfDataBase)
    
    rsp = MsgBox("Include headings?", vbYesNo, "Headings")
    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("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
    MsgBox "Data has been sent"
    
End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

basically....my range of data in sheet "main" start at (C5:N)

where row 5 and 6 are headers.

this macro was being used by another individual, so i am using it however im not strong with macros at all, so wondering what is possibly going wrong.

the macro is only copying column "C" the data in it, and that is it.

basically, this macro creates worksheets by column C i.e. city name, and dumps all data that belongs to i.e. Atlanta into a new worksheet.

but its only copying data from column C, and nothing else.

also, is it possible to have the formatting get copied as well? pls HELP!
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

Forum statistics

Threads
1,222,180
Messages
6,164,423
Members
451,894
Latest member
480BOY

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top