VB code to copy sheet format to another sheet
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("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "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
"Dave Peterson" wrote:
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
"Dave Peterson" wrote:
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("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
MsgBox "Data has been sent"
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function
Many thanks
--
ASU
"Dave Peterson" wrote:
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("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
|