VB code to copy sheet format to another sheet

[Guest]

Can some one tell me where i`m going wrong. The code below works fine except
for the sheet format. How do I get to copy column width, row hieght and
remove gridlines on the copied sheet.

Option Explicit

Sub FilterItems()

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

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

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

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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


Thank you

 

[Dave Peterson]

You can record a macro when you turn off grid lines to get that code.

You can loop through each column changing the width to what you found in the
other worksheet

dim iCol as long
for icol = 1 to columns.count
wks.columns(icol).columnwidth = databasewks.columns(icol).columnwidth
next icol


I would have thought that copying whole rows and pasting the whole rows would
have brought the rowheights, too.

But if it didn't maybe you can just autofit the rowheight




I think that this would be added in this portion:

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
'code to remove grid lines
wks.activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= databasewks.Columns(iCol).ColumnWidth
Next iCol
wks.rows.autofit
End If

 

[Guest]

Thank you dave it works fine.
--
ASU

You can record a macro when you turn off grid lines to get that code.

You can loop through each column changing the width to what you found in the
other worksheet

dim iCol as long
for icol = 1 to columns.count
wks.columns(icol).columnwidth = databasewks.columns(icol).columnwidth
next icol


I would have thought that copying whole rows and pasting the whole rows would
have brought the rowheights, too.

But if it didn't maybe you can just autofit the rowheight




I think that this would be added in this portion:

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
'code to remove grid lines
wks.activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= databasewks.Columns(iCol).ColumnWidth
Next iCol
wks.rows.autofit
End If

 

[Guest]

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Many thanks

 

[Dave Peterson]

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Many thanks

 

[Guest]

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Many thanks

 

[Dave Peterson]

Exactly.

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Many thanks
--
ASU

:

You can record a macro when you turn off grid lines to get that code.

You can loop through each column changing the width to what you found in the
other worksheet

dim iCol as long
for icol = 1 to columns.count
wks.columns(icol).columnwidth = databasewks.columns(icol).columnwidth
next icol


I would have thought that copying whole rows and pasting the whole rows would
have brought the rowheights, too.

But if it didn't maybe you can just autofit the rowheight




I think that this would be added in this portion:

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
'code to remove grid lines
wks.activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= databasewks.Columns(iCol).ColumnWidth
Next iCol
wks.rows.autofit
End If


ASU wrote:

Can some one tell me where i`m going wrong. The code below works fine except
for the sheet format. How do I get to copy column width, row hieght and
remove gridlines on the copied sheet.

Option Explicit

Sub FilterItems()

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

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

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

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Thank you

 

[Guest]

Sorry Dave. It seems that get one thing sorted and another crops up.
The workbook contains a sheet(MAIN) that I enter data under 12 headed
columns. Column "A" is a list of items which I use as a filter list to create
sheets for each of the items. When I select the macro that runs the code
below. It filters the list on sheet"MAIN" column "A" for each different item
it creates a new sheet or if the sheet already exsists, adds to the data to
it. It all works fine until it comes to pasting the values from sheet"MAIN"
to each row to their appropriate sheets. It`s only pasting values from the
first five cells in each row leaving the rest empty. How do I fix this???

Option Explicit

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
Dim iCol As Long


Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"

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

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

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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(10, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth =
DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Regards

--
ASU

Exactly.

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

ASU wrote:

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Many thanks
--
ASU

:

You can record a macro when you turn off grid lines to get that code.

You can loop through each column changing the width to what you found in the
other worksheet

dim iCol as long
for icol = 1 to columns.count
wks.columns(icol).columnwidth = databasewks.columns(icol).columnwidth
next icol


I would have thought that copying whole rows and pasting the whole rows would
have brought the rowheights, too.

But if it didn't maybe you can just autofit the rowheight




I think that this would be added in this portion:

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
'code to remove grid lines
wks.activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= databasewks.Columns(iCol).ColumnWidth
Next iCol
wks.rows.autofit
End If


ASU wrote:

Can some one tell me where i`m going wrong. The code below works fine except
for the sheet format. How do I get to copy column width, row hieght and
remove gridlines on the copied sheet.

Option Explicit

Sub FilterItems()

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

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

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

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

 

[Dave Peterson]

Put a line like:
msgbox mydatabase.address

right before this section:

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

What do you get for an address? Is it as large as you thought it would be?

Sorry Dave. It seems that get one thing sorted and another crops up.
The workbook contains a sheet(MAIN) that I enter data under 12 headed
columns. Column "A" is a list of items which I use as a filter list to create
sheets for each of the items. When I select the macro that runs the code
below. It filters the list on sheet"MAIN" column "A" for each different item
it creates a new sheet or if the sheet already exsists, adds to the data to
it. It all works fine until it comes to pasting the values from sheet"MAIN"
to each row to their appropriate sheets. It`s only pasting values from the
first five cells in each row leaving the rest empty. How do I fix this???

Option Explicit

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
Dim iCol As Long


Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"

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

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

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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(10, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth =
DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Regards

--
ASU

Exactly.

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

:

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

ASU wrote:

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
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

Many thanks
--
ASU

:

You can record a macro when you turn off grid lines to get that code.

You can loop through each column changing the width to what you found in the
other worksheet

dim iCol as long
for icol = 1 to columns.count
wks.columns(icol).columnwidth = databasewks.columns(icol).columnwidth
next icol


I would have thought that copying whole rows and pasting the whole rows would
have brought the rowheights, too.

But if it didn't maybe you can just autofit the rowheight




I think that this would be added in this portion:

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
'code to remove grid lines
wks.activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= databasewks.Columns(iCol).ColumnWidth
Next iCol
wks.rows.autofit
End If


ASU wrote:

Can some one tell me where i`m going wrong. The code below works fine except
for the sheet format. How do I get to copy column width, row hieght and
remove gridlines on the copied sheet.

Option Explicit

Sub FilterItems()

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

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

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

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

 

[Guest]

No that didn`t work. The filtering part works ok but out of the 12 columns
the last four remain empty.
--
ASU

Put a line like:
msgbox mydatabase.address

right before this section:

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

What do you get for an address? Is it as large as you thought it would be?

Sorry Dave. It seems that get one thing sorted and another crops up.
The workbook contains a sheet(MAIN) that I enter data under 12 headed
columns. Column "A" is a list of items which I use as a filter list to create
sheets for each of the items. When I select the macro that runs the code
below. It filters the list on sheet"MAIN" column "A" for each different item
it creates a new sheet or if the sheet already exsists, adds to the data to
it. It all works fine until it comes to pasting the values from sheet"MAIN"
to each row to their appropriate sheets. It`s only pasting values from the
first five cells in each row leaving the rest empty. How do I fix this???

Option Explicit

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
Dim iCol As Long


Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"

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

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

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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(10, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth =
DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Regards

--
ASU

Exactly.

ASU wrote:

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

:

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

ASU wrote:

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False

 

[Dave Peterson]

msgbox mydatabase.address
didn't work????

How can that be?

Try it again to see what the address is. Did you get what you expected?

No that didn`t work. The filtering part works ok but out of the 12 columns
the last four remain empty.
--
ASU

Put a line like:
msgbox mydatabase.address

right before this section:

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

What do you get for an address? Is it as large as you thought it would be?

Sorry Dave. It seems that get one thing sorted and another crops up.
The workbook contains a sheet(MAIN) that I enter data under 12 headed
columns. Column "A" is a list of items which I use as a filter list to create
sheets for each of the items. When I select the macro that runs the code
below. It filters the list on sheet"MAIN" column "A" for each different item
it creates a new sheet or if the sheet already exsists, adds to the data to
it. It all works fine until it comes to pasting the values from sheet"MAIN"
to each row to their appropriate sheets. It`s only pasting values from the
first five cells in each row leaving the rest empty. How do I fix this???

Option Explicit

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
Dim iCol As Long


Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"

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

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

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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(10, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth =
DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Regards

--
ASU

:

Exactly.

ASU wrote:

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

:

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

ASU wrote:

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False

 

[Guest]

No it didn`t work Dave but I now know what the problem is. Six of the 12
columns have the same title. This was causing some sort of conflict,
duplicating the figureson the first two columns and coping them to the rest(
if that makes sense). At the moment I have to find a way to rename those
columns or find a way through the code below.
Many thanks for your help. It was appreciated.
--
ASU

msgbox mydatabase.address
didn't work????

How can that be?

Try it again to see what the address is. Did you get what you expected?

No that didn`t work. The filtering part works ok but out of the 12 columns
the last four remain empty.
--
ASU

Put a line like:
msgbox mydatabase.address

right before this section:

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

What do you get for an address? Is it as large as you thought it would be?

ASU wrote:

Sorry Dave. It seems that get one thing sorted and another crops up.
The workbook contains a sheet(MAIN) that I enter data under 12 headed
columns. Column "A" is a list of items which I use as a filter list to create
sheets for each of the items. When I select the macro that runs the code
below. It filters the list on sheet"MAIN" column "A" for each different item
it creates a new sheet or if the sheet already exsists, adds to the data to
it. It all works fine until it comes to pasting the values from sheet"MAIN"
to each row to their appropriate sheets. It`s only pasting values from the
first five cells in each row leaving the rest empty. How do I fix this???

Option Explicit

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
Dim iCol As Long


Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"

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

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

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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(10, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth =
DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Regards

--
ASU

:

Exactly.

ASU wrote:

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

:

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

ASU wrote:

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth

 

[Dave Peterson]

The msgbox should have worked--in the sense that it gave you some string that
looked like an address.

But I understand how you found the problem. Maybe you could just rename the
columns to something unique.

No it didn`t work Dave but I now know what the problem is. Six of the 12
columns have the same title. This was causing some sort of conflict,
duplicating the figureson the first two columns and coping them to the rest(
if that makes sense). At the moment I have to find a way to rename those
columns or find a way through the code below.
Many thanks for your help. It was appreciated.
--
ASU

msgbox mydatabase.address
didn't work????

How can that be?

Try it again to see what the address is. Did you get what you expected?

No that didn`t work. The filtering part works ok but out of the 12 columns
the last four remain empty.
--
ASU

:

Put a line like:
msgbox mydatabase.address

right before this section:

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

What do you get for an address? Is it as large as you thought it would be?

ASU wrote:

Sorry Dave. It seems that get one thing sorted and another crops up.
The workbook contains a sheet(MAIN) that I enter data under 12 headed
columns. Column "A" is a list of items which I use as a filter list to create
sheets for each of the items. When I select the macro that runs the code
below. It filters the list on sheet"MAIN" column "A" for each different item
it creates a new sheet or if the sheet already exsists, adds to the data to
it. It all works fine until it comes to pasting the values from sheet"MAIN"
to each row to their appropriate sheets. It`s only pasting values from the
first five cells in each row leaving the rest empty. How do I fix this???

Option Explicit

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
Dim iCol As Long


Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"

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

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

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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(10, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth =
DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

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("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Regards

--
ASU

:

Exactly.

ASU wrote:

Thanks Dave it works great now. I suppose if I wanted to copy the borders
too. I would add it to the end of the code you sent me?
--
ASU

:

It uses the values in that listrange to change the name of the worksheet.

If there's something in any of those cells that contain characters that can't be
used for a sheet name (like :, /, \, [, ]) or something that would result in an
invalid name (longer than 31 characters), then you'll be prompted to change the
name of the sheet.

You could change this line to give you more of a hint:

MsgBox "Please rename: " & wks.Name
to
MsgBox "Please rename: " & wks.Name & vblf & "Invalid: " & mycell.value

ASU wrote:

I counted my eggs too soon.
When run the code below, it keeps asking me to name the sheet. This happens
several times. Can some one run through this code and tell me what is wrong
with it........Please!!!
It basically supose to create a new named worksheet for each item in a
filtered list...it doesn`t now......help

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

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

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

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, "B").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")
'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth _
= DataBaseWks.Columns(iCol).ColumnWidth