On May 4, 1:07 pm, Tom Ogilvy <TomOgi...@discussions.microsoft.com>
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
Similar Threads
