Macro to break data into worksheets

A

Amy S.

I am running a report each month (with an inconsistant number of rows) that
needs to be cut and pasted into either seperate worksheets, or sepearte
files. Can I write a macro that will be able to break out data based on
customer number and automatically place it into new worksheets? I could
filter and then do the cut/past motions through the macro but this is too
many actions and it is too labor intensive. There has to be a better way --
ideas?
 
A

Amy S.

This looks like exactly what I'm looking for, but I don't understand the
programming language. Can you tell me in excel-for-dummies terms?
Thanks!
 
R

Ron de Bruin

Hi Amy

Give me this information and I will guide you

In files or in sheets ?

Do you have headers in the first row of your range ?

In which row start your data ?
Is this also your header row ?
 
A

Amy S.

Thanks,
I would like to divide this out into sheets. I do have a headder row (row
1). Data starts in row 2. Example of first few rows...

OTCBIL UPC NDC CIN DESC
460628 09629578355 437205034178 1783554 LDR IBUPROFEN
460628 04116705703 041167005703 1241249 ASPERCREME
460628 04116700885 041167008805 1141878 ICY HOT TUBE
460628 30009364801 000009364804 1496066 DRAMAMINE
460628 09629510912 437205000805 2804151 LDR PAIN RELVR
460628 30067034365 000067021965 2793180 MAALOX QCK
 
R

Ron de Bruin

Hi Amy

The data is on a sheet named Sheet1
You can change the sheet name in this code line
You say your data start in Row 1 so if your first column is A then you
don't have to change this line
I asume that you want to filter on the numbers in column A
If that is not correct you must change the number 1 to the other column number

1) create a backup of your workbook
2) Alt-F11 to open the VBA editor
3) Insert>Module from the menubar
4) Paste the sub in there
5) Alt-Q to go back to Excel

If you use Alt-F8 you get a list of your macro's
Select "Copy_With_AdvancedFilter_To_Worksheets" and press Run

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("Sheet1") '<<< Change
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

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

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change this if needed)
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use the columns)

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
 
A

Amy S.

Perfect, thank you so much!!

Ron de Bruin said:
Hi Amy

The data is on a sheet named Sheet1
You can change the sheet name in this code line

You say your data start in Row 1 so if your first column is A then you
don't have to change this line

I asume that you want to filter on the numbers in column A
If that is not correct you must change the number 1 to the other column number


1) create a backup of your workbook
2) Alt-F11 to open the VBA editor
3) Insert>Module from the menubar
4) Paste the sub in there
5) Alt-Q to go back to Excel

If you use Alt-F8 you get a list of your macro's
Select "Copy_With_AdvancedFilter_To_Worksheets" and press Run

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("Sheet1") '<<< Change
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

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

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change this if needed)
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use the columns)

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
Click to expand...
 
Top