Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
ASU ASU is offline
external usenet poster
 
Posts: 63
Default 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
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
How to copy a conditional format from one sheet to another? billz Excel Discussion (Misc queries) 1 February 15th 07 10:33 PM
VB code to copy sheet format to another sheet ASU Excel Discussion (Misc queries) 12 August 10th 06 02:37 AM
How do I format a sheet using a copy macro? Nimbus55 Excel Programming 1 April 1st 06 04:46 AM
copy cell from one sheet of worksheet to another sheet Planetjim Excel Discussion (Misc queries) 1 January 10th 06 09:36 AM
How do I copy a print format from sheet to sheet in excel ? kernat Excel Discussion (Misc queries) 1 July 22nd 05 04:59 PM


All times are GMT +1. The time now is 08:08 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"