Copy Paste sections of data

[Nikki]

Hi All:
I have 32,000 lines of data that is subtotalled by customer Name and sales
totals. Is there a way to copy and paste into a new worksheet at each change
in customer name? I found code that will work for a simple copy and past but
do any of you have a code that will copy and paste into a new workbook at
each change in name. I need to separate each customer so I can email each
individual file to each customer.

Thank to you all for your help.

Nikki )

 

[Dave Peterson]

I'd look here first:

Ron de Bruin's EasyFilter addin:
http://www.rondebruin.nl/easyfilter.htm

And then here:

Code from Debra Dalgleish's site:
http://www.contextures.com/excelfiles.html

Create New Sheets from Filtered List -- uses an Advanced Filter to create
separate sheet of orders for each sales rep visible in a filtered list; macro
automates the filter. AdvFilterRepFiltered.xls 35 kb

Update Sheets from Master -- uses an Advanced Filter to send data from
Master sheet to individual worksheets -- replaces old data with current.
AdvFilterCity.xls 55 kb

 

[Bernie Deitrick]

Nikki,

Take off the subtotals, then run the code below. Select one cell within your database and, when
asked, reply with the column letter on which to base the extract.

Also, I have assumed that you have a header row, contiguous data, and that workbook name wanted is
"Workbook " plus the keyvalue.


HTH,
Bernie
MS Excel MVP


Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As String
Dim myField As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column letter to use as key?")

Set myArea = Intersect(ActiveCell.CurrentRegion, Range(KeyCol & "1").EntireColumn).Cells

Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - ActiveCell.CurrentRegion.Cells(1).Column + 1

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=myField, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub

 

[Nikki]

Thank you - this is such a time saver....

Nikki,

Take off the subtotals, then run the code below. Select one cell within your database and, when
asked, reply with the column letter on which to base the extract.

Also, I have assumed that you have a header row, contiguous data, and that workbook name wanted is
"Workbook " plus the keyvalue.


HTH,
Bernie
MS Excel MVP


Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As String
Dim myField As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column letter to use as key?")

Set myArea = Intersect(ActiveCell.CurrentRegion, Range(KeyCol & "1").EntireColumn).Cells

Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - ActiveCell.CurrentRegion.Cells(1).Column + 1

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=myField, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub

 

[Nikki]

Can I ask one more question? Since I have used your code to copy and paste
each Sales Rep into a new file, I now need to subtotal each customer and then
by item number. I can create a simple Macro and go into each file and create
two subtotals. However, is there a code that would allow me to subtotal each
customer then by products within each customer? I know I could subtotal by
customer and then create a new subtotal by Item but wanted to see if there
was another way to tackle this.

Thanks again.....you are very helpful and have saved my day!!!!!

 

[Bernie Deitrick]

Nikki,

Take a look at Pivot tables, which allow you to very easily do subtotals and totals based on almost
any criteria. You could add code that would take the created sub-database and use it as the source
of a pivot table, added to a new sheet in each workbook, perhaps.

Play with the pivot table, and when you get it looking the way you want, delete the pivot table and
start recording a macro, then recreate the pivot table. Then post the code here, and we can make it
flexible to work with various size data sets.

HTH,
Bernie
MS Excel MVP

 

[Nikki]

Pivot Tables are excellent but I need to send the files to Sales folks in the
field and they are not "technically savy" enough to work with Pivot Tables.
Is there a way to get subtotals to work. Each time I subtotal my data looks
messed up when I perform the second subtotal. Any other ideas?
Thanks again..

 

[Bernie Deitrick]

Nikki,

I don't know your data structure, but assuming you want to group by column A, then by B (each time
summing the data in C), you could use something like this to first sort the data, and then add the
subtotals. If you have more than three columns, you will need to adjust "A1:C" by changing the C to
your last column letter...and other changes. But, going on three columns for now, add this new code
after the line

mySht.Cells.EntireColumn.AutoFit

'***New code****

With mySht.Range("A1:C" & mySht.Cells(Rows.Count, 3).End(xlUp).Row)
.Sort Key1:=mySht.Range("A2"), _
Order1:=xlAscending, Key2:=mySht.Range("B2"), Order2:=xlAscending, _
Header:=xlYes
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True
End With

HTH,
Bernie
MS Excel MVP

 

[Nikki]

One last question and I promise I will not ask another one "today" that
is....ha ha - can you please tell me where would be a good place to insert my
print range setup macro. I am trying to add this at the end but it is giving
me an error. I am new to this can you tell? Thanks so so so much....

 

[Bernie Deitrick]

Nikki,

After the line

mySht.Cells.EntireColumn.AutoFit

use something like

mySht..PageSetup.PrintArea = "$A$1:$D$" & mySht.Cells(Rows.Count,4).End(xlUp).Row

Remember, the printArea property takes a string (the range address), not a range.

HTH,
Bernie
MS Excel MVP

 

[Bernie Deitrick]

Oops. I put two dots in mySht..PageSetup - should only be one.....

HTH,
Bernie
MS Excel MVP

 

[Nikki]

What if I wanted to add in legal paper size instead of Letter?

 

[Bernie Deitrick]

mySht.PageSetup.PaperSize = xlPaperLegal


HTH,
Bernie
MS Excel MVP