Automatic Formatting Code

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

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
 
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
 
Thanks so much! Worked great!

Tom Ogilvy said:
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
Click to expand...
 
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









- Show quoted text -
Click to expand...

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
 
Back
Top