Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
copy sheet format to new worksheet
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 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 -- ASU |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
How to copy a conditional format from one sheet to another? | Excel Discussion (Misc queries) | |||
VB code to copy sheet format to another sheet | Excel Discussion (Misc queries) | |||
How do I format a sheet using a copy macro? | Excel Programming | |||
copy cell from one sheet of worksheet to another sheet | Excel Discussion (Misc queries) | |||
How do I copy a print format from sheet to sheet in excel ? | Excel Discussion (Misc queries) |