Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. :o)

Two issues:

1. (See code at the end of this message). My raw data sheet contains 1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns of
data had the same problem.

Sample Data:
A B C
LastName, FirstName Title Department.....

The worksheets created sort the employees by department. Cells A, B, C, L,
O, R, U & X are text and all others are $.


2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?

Thanks so much for your help as always.

Scott

Macro I am using now:

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

do you have a blank column within your data on the datasheet. This might be
problematic. (guessing column O is blank).

--
Regards,
Tom Ogilvy

"Scott" wrote in message
...
Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. :o)

Two issues:

1. (See code at the end of this message). My raw data sheet contains
1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns
of
data had the same problem.

Sample Data:
A B C
LastName, FirstName Title Department.....

The worksheets created sort the employees by department. Cells A, B, C,
L,
O, R, U & X are text and all others are $.


2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?

Thanks so much for your help as always.

Scott

Macro I am using now:

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

There are values. I even tried doing a replace on all "" with 0 and had the
same result.

"Tom Ogilvy" wrote:

do you have a blank column within your data on the datasheet. This might be
problematic. (guessing column O is blank).

--
Regards,
Tom Ogilvy

"Scott" wrote in message
...
Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. :o)

Two issues:

1. (See code at the end of this message). My raw data sheet contains
1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns
of
data had the same problem.

Sample Data:
A B C
LastName, FirstName Title Department.....

The worksheets created sort the employees by department. Cells A, B, C,
L,
O, R, U & X are text and all others are $.


2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?

Thanks so much for your help as always.

Scott

Macro I am using now:

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

Hi Scott

Do you have columns with the same header ??




--
Regards Ron de Bruin
http://www.rondebruin.nl


"Scott" wrote in message ...
There are values. I even tried doing a replace on all "" with 0 and had the
same result.

"Tom Ogilvy" wrote:

do you have a blank column within your data on the datasheet. This might be
problematic. (guessing column O is blank).

--
Regards,
Tom Ogilvy

"Scott" wrote in message
...
Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. :o)

Two issues:

1. (See code at the end of this message). My raw data sheet contains
1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns
of
data had the same problem.

Sample Data:
A B C
LastName, FirstName Title Department.....

The worksheets created sort the employees by department. Cells A, B, C,
L,
O, R, U & X are text and all others are $.


2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?

Thanks so much for your help as always.

Scott

Macro I am using now:

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

Yes, columns follow this model from "I" through "Y"

"I" header = "Option"
"J" header = "Buyout"
"K" header = "2006 Salary" (incremented by one year for each group)



"Ron de Bruin" wrote:

Hi Scott

Do you have columns with the same header ??




--
Regards Ron de Bruin
http://www.rondebruin.nl


"Scott" wrote in message ...
There are values. I even tried doing a replace on all "" with 0 and had the
same result.

"Tom Ogilvy" wrote:

do you have a blank column within your data on the datasheet. This might be
problematic. (guessing column O is blank).

--
Regards,
Tom Ogilvy

"Scott" wrote in message
...
Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. :o)

Two issues:

1. (See code at the end of this message). My raw data sheet contains
1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns
of
data had the same problem.

Sample Data:
A B C
LastName, FirstName Title Department.....

The worksheets created sort the employees by department. Cells A, B, C,
L,
O, R, U & X are text and all others are $.


2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?

Thanks so much for your help as always.

Scott

Macro I am using now:

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

Hi Scott

Change the headers to Option1, Option2 so all headers are unique

Send me the file private with your code in it and I look at it for you if this is
not working



--
Regards Ron de Bruin
http://www.rondebruin.nl


"Scott Wagner" wrote in message ...
Yes, columns follow this model from "I" through "Y"

"I" header = "Option"
"J" header = "Buyout"
"K" header = "2006 Salary" (incremented by one year for each group)



"Ron de Bruin" wrote:

Hi Scott

Do you have columns with the same header ??




--
Regards Ron de Bruin
http://www.rondebruin.nl


"Scott" wrote in message ...
There are values. I even tried doing a replace on all "" with 0 and had the
same result.

"Tom Ogilvy" wrote:

do you have a blank column within your data on the datasheet. This might be
problematic. (guessing column O is blank).

--
Regards,
Tom Ogilvy

"Scott" wrote in message
...
Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. :o)

Two issues:

1. (See code at the end of this message). My raw data sheet contains
1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns
of
data had the same problem.

Sample Data:
A B C
LastName, FirstName Title Department.....

The worksheets created sort the employees by department. Cells A, B, C,
L,
O, R, U & X are text and all others are $.


2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?

Thanks so much for your help as always.

Scott

Macro I am using now:

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

That worked. Thank you so much. Can you answer my second question from this
posting?

2. How can I get the macro below to perform AutoFit on all the worksheets
it creates? (see code below)

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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

Hi Scott

Yes this is a strange bug (they promise me to make a Knowledge Base article about it)

In the xlFilterCopy part of the code add
wks.Columns.AutoFit
after the copy



--
Regards Ron de Bruin
http://www.rondebruin.nl


"Scott Wagner" wrote in message ...
That worked. Thank you so much. Can you answer my second question from this
posting?

2. How can I get the macro below to perform AutoFit on all the worksheets
it creates? (see code below)

Sub FilterCities()

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 = "A1"

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

'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = 6

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 Team 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

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)

'transfer data to individual Team 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

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