Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Automatic Formatting Code
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 2
Default Automatic Formatting Code
When I produce "sorted" sheets using the following code below, I am not able
to carry the formatting to the new sheets. Any ideas would be appreciated.
Thanks in advance!

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub
Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 6,953
Default Automatic Formatting Code
I believe you are correct that advanced filter doesn't copy the formatting.
If it isn't too complex, perhaps adding


Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Sheets("sheet1").Cells.copy
Sheets(c.value).Cells.Pastespecial xlformats
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Sheets("sheet1").Cells.copy
wsNew.Cells.Pastespecial xlformats
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub

--
Regards,
Tom Ogilvy

"Eng97" wrote:

When I produce "sorted" sheets using the following code below, I am not able
to carry the formatting to the new sheets. Any ideas would be appreciated.
Thanks in advance!

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub
Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 2
Default Automatic Formatting Code
Thanks so much! Worked great!

"Tom Ogilvy" wrote:

I believe you are correct that advanced filter doesn't copy the formatting.
If it isn't too complex, perhaps adding


Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Sheets("sheet1").Cells.copy
Sheets(c.value).Cells.Pastespecial xlformats
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Sheets("sheet1").Cells.copy
wsNew.Cells.Pastespecial xlformats
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub

--
Regards,
Tom Ogilvy

"Eng97" wrote:

When I produce "sorted" sheets using the following code below, I am not able
to carry the formatting to the new sheets. Any ideas would be appreciated.
Thanks in advance!

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub
Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 142
Default Automatic Formatting Code
On May 4, 1:07 pm, Tom Ogilvy
wrote:
I believe you are correct that advanced filter doesn't copy the formatting.
If it isn't too complex, perhaps adding

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Sheets("sheet1").Cells.copy
Sheets(c.value).Cells.Pastespecial xlformats
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Sheets("sheet1").Cells.copy
wsNew.Cells.Pastespecial xlformats
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub

--
Regards,
Tom Ogilvy



"Eng97" wrote:
When I produce "sorted" sheets using the following code below, I am not able
to carry the formatting to the new sheets. Any ideas would be appreciated.
Thanks in advance!

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cs As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Project Officers
ws1.Columns("C:C").Copy _
Destination:=Range("CM1")
ws1.Columns("CM:CM").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("CK1"), Unique:=True
cs = Cells(Rows.Count, "CK").End(xlUp).Row

'set up Criteria Area
Range("CM1").Value = Range("C1").Value

For Each c In Range("CK2:CK" & cs)
'add the rep name to the criteria area
ws1.Range("CM2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("CM1:CM2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("CK:CM").Delete
End Sub- Hide quoted text -

- Show quoted text -

Tom,
I use a very similar code from http://www.rondebruin.nl/copy5.htm
When I use it, I get the formatting along with values. Maybe
something in here can help. I am getting ready to leave so I can't go
deeper, but maybe you can...

Rob

Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long

Set ws1 = Sheets("Sorted by LSkD, STDOE, LSD") '<<< Change
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(14).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & "
manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
Next
.Columns("IU:IV").Clear
End With
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

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
automatic formatting Larry Gagnon Excel Discussion (Misc queries) 1 March 19th 09 06:25 PM
automatic formatting [email protected] Excel Worksheet Functions 5 March 4th 08 06:59 PM
Automatic code customizing Peter Ostermann[_3_] Excel Programming 0 July 24th 06 06:52 PM
Automatic formatting help? Mel Excel Discussion (Misc queries) 6 June 20th 06 05:35 PM
Automatic Row Formatting Chris Hughes Excel Discussion (Misc queries) 3 April 14th 05 11:17 PM


All times are GMT +1. The time now is 03:41 AM.

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

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement