PDA

View Full Version : excel 2016 splitting datasets creating new separate sheets



kenyongraham
06-04-2016, 02:32 AM
Hi,

I am trying to split a worksheet that contains a list of data into seperate excel 2016 work sheets.

I have attached the workbook, I am attempting to put all the data categorised in column D:D on sheet 1 on separate sheets named 1, 2,3 4.... corresponding to the case integers ie. 1 to 23

There is an attached macro but I'm stumped on creatimg the loop.

I'm off to read my excel vba for dummies. Frustratingily I use to be able to achieve this.

Too many grey cells have gone to make way for invaluable facebook rubbish.

rgds

Kenyon

1631616316

mdmackillop
06-04-2016, 02:59 AM
Welcome to VBAX
I still use the macro recorder. Here for info is the recorded macro and the edited version.
Note that there is no error checking for existing filters or output sheets which would affect the running of the macro.

Option Explicit

Sub Macro5()
Sheets("Sheet1").Select
Range("B10").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFilter
ActiveWindow.SmallScroll Down:=-21
ActiveSheet.Range("$B$10:$J$16282").AutoFilter Field:=3, Criteria1:="1"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "01"
Range("C11").Select
Sheets("Sheet1").Select
Selection.Copy
Sheets("01").Select
Range("B11").Select
ActiveSheet.Paste
End Sub


Sub Test()
Dim r As Range
Dim i As Long, j As Long

Set r = Sheets("Sheet1").Range("B10").CurrentRegion
j = Application.Max(r.Columns(3))

For i = 1 To j
r.AutoFilter Field:=3, Criteria1:=i
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Format(i, "00")
r.SpecialCells(xlCellTypeVisible).Copy Range("B11")
Next i
r.AutoFilter
End Sub

snb
06-04-2016, 07:18 AM
or

Sub M_snb()
Sheet1.Cells(1, 20) = [D10]

For j = 1 To 23
Sheets.Add(, Sheets(Sheets.Count)).Name = "S_" & j
Sheet1.Cells(2, 20) = j
Sheet1.Cells(10, 2).CurrentRegion.AdvancedFilter 2, Sheet1.Range("T1:T2"), Sheets("S_" & j).Cells(1)
Next

End Sub