Hi Bart
This example have a sheet with the data named "Sheet1" and before it split the data it delete the columns you want in this sheet
I will add a sum formula in column C of every sheet it create
Maybe you want to change the column in the filter range ?
Set rng = ws1.Range("A1:IV" & Rows.Count)
Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Set ws1 = Sheets("Sheet1") '<<< Change
With ws1
.Range("Z:AH").Delete Shift:=xlShiftToLeft
.Range("W:W").Delete Shift:=xlShiftToLeft
.Range("L:M").Delete Shift:=xlShiftToLeft
.Range("F:J").Delete Shift:=xlShiftToLeft
End With
'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:IV" & Rows.Count)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'This example filters on the first column in the range
'first we copy the Unique data from this column to ws2
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), Unique:=True
'Then give A1 the same value as B1 (header of column 1) in ws2
.Range("A1").Value = .Range("B1").Value
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "B").End(xlUp).Row
For Each cell In .Range("B2:B" & Lrow)
.Range("A2").Value = "=" & Chr(34) & "=" & cell.Value & Chr(34)
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("A1:A2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Range("C" & Rows.Count).End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R1C:R[-2]C)"
WSNew.Columns.AutoFit
Next
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
--
Regards Ron de Bruinhttp://
www.rondebruin.nl/tips.htm
AA Arens said:
A:
Which macro do you use from that page?
B:
You see this block in the macro
For Each Sh In Basebook.Worksheets
....
...
..
Next Sh
Replace this with the code I posted
I must go now so I will read your reply tomorrow
--
Regards Ron de Bruinhttp://
www.rondebruin.nl/tips.htm
For (A):
I have placed under the DIM \codes:
Worksheets("TelkomSel").Range("Z:AH").Delete Shift:=xlShiftToLeft
Worksheets("TelkomSel").Range("W:W").Delete Shift:=xlShiftToLeft
Worksheets("TelkomSel").Range("L:M").Delete Shift:=xlShiftToLeft
Worksheets("TelkomSel").Range("F:J").Delete Shift:=xlShiftToLeft
because I first want to clean up the stuff.
2nd: I have also the headers copied, so the summary should start on
the second row instead of the first. How will be the code you gave me
and where do I have to place it in the present script I mentioned
under A.
For (B): Where to add this code in the script I mentioned in B?
Bart
Ron de Bruin wrote:
Hi Bart
A:
This will add a Sum formula in column C
Range("C" & Rows.Count).End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R1C:R[-2]C)"
B:
One way
You can fill in the sheet names in the array that you want to exclude
For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
If IsError(Application.Match(Sh.Name, _
Array("Sheet1", "Sheet3"), 0)) Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
For Each myCell In Sh.Range("A1,D5:E5,Z10") '<--Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
End If
Next Sh
--
Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm
A) I use Ron de Bruin's script "Copy records with the same value in a
column to a new sheet or workbook". How to add VB code that totalize
one of the columns and write the value under the last row?
See the scripthttp://
www.rondebruin.nl/copy5.htm
B) How to exclude sheet "name" from being summerized?
See the sript:
http://www.rondebruin.nl/summary.htm
Bart
Ron, I uses the automatic one: Copy_With_AdvancedFilter_To_Worksheets()
