HELP. Can this be done easily? Save me HOURS of work.
 

We have a spreadsheet with 12,000 rows on it. Each column is standard things like Name, Address, Phone, etc. The last column we'll call OWNER (I'm not sure on the exact name).

Every row has unique information for people who attended our event except the OWNER field. The owner field is the name of the person who sold the person their ticket.

So, the OWNER field could have one name in it 3 times, one name in it 50 times, one name in it 1000 times, etc.

END RESULT
What we need to do is break out the list into individual XLS files so that each OWNER has a file of the people that he sold tickets to.

Currently someone is going through the list, higlighting all the infor for each OWNER, cutting and pasting it into it's own file... This is going to take many many many hours to complete. Anyone have a way of automating this? The name of each XLS file could jsut be the same data as is in the OWNER field.

I'm just a beginner at Macros and such but if someone has somethign like this, PLEASE let me know ASAP.

Thanks!

HELP. Can this be done easily? Save me HOURS of work.
 

A start would be to use an autofilter.

Assume your first row has headers like Name, address, owner

click in any single cell with such a header label in the first row and then
do Data=Filter=Autofilter

Go to the owner column and click the dropdown, select an owner

Now only sales by that owner will be visible.

Click in A1 and do Ctrl+Shift+8, then do copy, go to another workbook and
select A1, then do edit=Paste

If you turn on the macro recorder while you do this manually, this will give
you the basic code you need.

You could then build an array of owner names and put the code inside a loop
where you loop through owner names.

--
Regards,
Tom Ogilvy

"Mr B" wrote in message
...
We have a spreadsheet with 12,000 rows on it. Each column is standard
things like Name, Address, Phone, etc. The last column we'll call OWNER
(I'm not sure on the exact name).

Every row has unique information for people who attended our event except
the OWNER field. The owner field is the name of the person who sold the
person their ticket.

So, the OWNER field could have one name in it 3 times, one name in it 50
times, one name in it 1000 times, etc.

END RESULT
What we need to do is break out the list into individual XLS files so that
each OWNER has a file of the people that he sold tickets to.

Currently someone is going through the list, higlighting all the infor for
each OWNER, cutting and pasting it into it's own file... This is going to
take many many many hours to complete. Anyone have a way of automating
this? The name of each XLS file could jsut be the same data as is in the
OWNER field.

I'm just a beginner at Macros and such but if someone has somethign like
this, PLEASE let me know ASAP.

Thanks!

HELP. Can this be done easily? Save me HOURS of work.
 

I tried this on a sheet with 13000 rows and it took about 2 minutes.

Code
-------------------
Sub NewSheets()

Dim iLast As Long
Dim iOwnerLast As Long
Dim i As Long
Dim s
Dim strOwner
Dim bFound As Boolean

Sheets("Sheet3").Select

iLast = Range("A65536").End(xlUp).Row

For i = 1 To iLast
strOwner = Cells(i, 6).Value
bFound = False
For Each s In Sheets
If s.Name = strOwner Then
bFound = True
Exit For
End If
Next
If bFound = True Then
iOwnerLast = Sheets(strOwner).Range("A65536").End(xlUp).Row + 1
Range("A" & i & ":F" & i).Copy Sheets(strOwner).Range("A" & iOwnerLast)
Else
Sheets.Add
ActiveSheet.Name = strOwner
Range("A1").Value = "Name"
Range("B1").Value = "Address"
'etc. for your headers
Sheets("Sheet3").Select
Range("A" & i & ":F" & i).Copy Sheets(strOwner).Range("A2")
End If

Next

End Su
-------------------

You will need make the following changes:
- Change Sheet3 to the name of your main data sheet (2 places)
- strOwner = Cells(i, 6).Value change the 6 to the column number wit
the owner name.
- Range("A" & i & ":F" & i).Copy change the F to the last column lette
for your data.
- Add additional headers near the end of my code where the comment is

I'm pretty sure it will work, but test it on a copy of your workboo
(please).

What it does is create a new sheet in the current workbook for each ne
name. You can then copy each of these sheets into a new workbook an
save it. Not exactly what you wanted, but close.

K

Oh, by the way, paste the code into a new module in the VB Editor.
Select Tools | Macros | Visual Basic Editor. From the project windo
on the left, right click the workbook name and select Insert | Module.
Paste the code there. Push F5 to run

--
Message posted from http://www.ExcelForum.com

HELP. Can this be done easily? Save me HOURS of work.
 

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim lr As Long
Dim ofer As Long
Dim lc As Long
Dim x As Long
Dim y As Long
Dim num As Integer
Dim wsExists As Boolean
Dim Data As Worksheet
Dim OWS As Worksheet
Set Data = Worksheets("Sheet1")
lr = Data.UsedRange.Row - 1 + Data.UsedRange.Rows.Count
lc = Data.UsedRange.Column - 1 + Data.UsedRange.Columns.Count
For x = 1 To lr
owner = Data.Cells(x, lc).Value
wsExists = False
num = Worksheets.Count
For z = 1 To num
If CStr(Worksheets(z).Name) = owner Then
wsExists = True
End If
Next z
If wsExists = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(num + 1).Name = owner
End If
Set OWS = Worksheets(CStr(owner))
ofer = OWS.UsedRange.Row + OWS.UsedRange.Rows.Count
Data.Rows(x).Copy Destination:=OWS.Cells(ofer, 1)
Next x
Application.ScreenUpdating = True
End Sub
- Piku

--
Message posted from http://www.ExcelForum.com

HELP. Can this be done easily? Save me HOURS of work.
 

That would be perfect. Now I'd just need a macro to take each sheet and save it as a file of the same name... Have one of those? Maybe I shoudl start another topic for that one

HELP. Can this be done easily? Save me HOURS of work.
 

Or maybe it would be better to have it save each sheet to it's own file as they are created? This macro will cause me to have 500 - 600 sheets and I don't know if that would break anything..

But it works great so far.

HELP. Can this be done easily? Save me HOURS of work.
 

I can't quite figure out how to do the move and save feature (kee
getting an error on the ActiveWorkbook.SaveAs method. But to mak
things a bit easier, here is simple code to move them all to their ow
workbooks.


Code
-------------------
Sub MoveSheets()

Dim s

For Each s In Sheets
If s.Name = "Main" Then
s.Move
Windows("Book1").Activate
End If
Next

End Su
-------------------

Now you just have to save as 600 times! As for incorporating into th
original, that would be best, but I wouldn't recommend it if the macr
you have works.



--
Message posted from http://www.ExcelForum.com

HELP. Can this be done easily? Save me HOURS of work.
 

Well sorry to keep replying to my own posts but I made a thing to take the sheets and save them as their own files... So I think that's all I need. This is what I did (made by recording keystrokes and then modifying it

Starts at Sheet 1 (master data sheet) and moves through the other ones that were created with the first macro. I'm sure there's some extra lines in there but it seems to work OK..

Sub testnewsheet(

Dim shname As Strin

ActiveSheet.Next.Selec
shname = ActiveSheet.Nam
Cells.Selec
Range("C1").Activat
Selection.Cop
Workbooks.Ad
ActiveSheet.Past
Application.CutCopyMode = Fals
Workbooks(2).Activat
ActiveWorkbook.SaveAs Filename:="D:\Docs\" & shname & ".xls", FileFormat:=xlNormal,
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,
CreateBackup:=Fals
ActiveWindow.Clos
End Su

HELP. Can this be done easily? Save me HOURS of work.
 

You mean it moves through each sheet if you run it 500 to 600 times,
correct?

--
Regards,
Tom Ogilvy

"Mr B" wrote in message
...
Well sorry to keep replying to my own posts but I made a thing to take the
sheets and save them as their own files... So I think that's all I need.
This is what I did (made by recording keystrokes and then modifying it)

Starts at Sheet 1 (master data sheet) and moves through the other ones
that were created with the first macro. I'm sure there's some extra lines
in there but it seems to work OK...


Sub testnewsheet()

Dim shname As String

ActiveSheet.Next.Select
shname = ActiveSheet.Name
Cells.Select
Range("C1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Workbooks(2).Activate
ActiveWorkbook.SaveAs Filename:="D:\Docs\" & shname & ".xls",
FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
End Sub

HELP. Can this be done easily? Save me HOURS of work.
 

Mr B

building on Tom's original suggestion, the following macro should create a
new workbook for each OWNER.

I have assumed that the OWNER column is D

Option Explicit
Sub CreateOwnerWorkbooks()
' assumes that the OWNER column is column D
Dim masterWB As Workbook
Dim newWB As Workbook
Dim filterRange As Range
Dim cell As Range
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set masterWB = ThisWorkbook
With masterWB
With ActiveSheet
' create a temporary list of unique OWNERS
.Range("D:D").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
' loop through each of the unique OWNERS
' and filter on that value
Set filterRange = .Range("iv2:iv" & .Range("iv2").End(xlDown).Row)
For Each cell In filterRange
With .Range("A1")
' filter on column D (field:=4)
.AutoFilter Field:=4, Criteria1:=cell
' copy the current range, visible cells
.CurrentRegion.Copy
' create a new workbook
Set newWB = Workbooks.Add
' paste the data
ActiveSheet.Paste
' save and close the new workbook
' with the OWNER as the name (cell.value)
newWB.SaveAs Filename:=cell.Value
newWB.Close
.AutoFilter
Application.CutCopyMode = False
End With
Next 'cell
' clear the temporary list of unique OWNERS
filterRange.Offset(-1, 0).Resize( _
filterRange.Rows.Count + 1, filterRange.Columns.Count).Clear
End With
End With
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

It looks longer and more complicated than it actually is because I've
included comments for most of the lines of code.

I've only tested it with a few rows but it should be relatively quick
depending on the number of unique OWNERs

Regards

Trevor


"Mr B" wrote in message
...
We have a spreadsheet with 12,000 rows on it. Each column is standard
things like Name, Address, Phone, etc. The last column we'll call OWNER
(I'm not sure on the exact name).

Every row has unique information for people who attended our event except
the OWNER field. The owner field is the name of the person who sold the
person their ticket.

So, the OWNER field could have one name in it 3 times, one name in it 50
times, one name in it 1000 times, etc.

END RESULT
What we need to do is break out the list into individual XLS files so that
each OWNER has a file of the people that he sold tickets to.

Currently someone is going through the list, higlighting all the infor for
each OWNER, cutting and pasting it into it's own file... This is going to
take many many many hours to complete. Anyone have a way of automating
this? The name of each XLS file could jsut be the same data as is in the
OWNER field.

I'm just a beginner at Macros and such but if someone has somethign like
this, PLEASE let me know ASAP.

Thanks!

HELP. Can this be done easily? Save me HOURS of work.
 

Thanks again

I used your original script (with minor mods to suit my sheet) and that worked great. I then used the code I pasted in before to take each oen and Move it to it's own book, save that book, close that book, then do the same with the next one

Worked great.

HELP. Can this be done easily? Save me HOURS of work.
 

Hi Trevor,
I used your suggested code for Mr. B with minor changes. The difference
is I need to copy teh filtered data into a new worksheet within the
existing workbook and print it. It doesn't seem to paste the filtered
data into the new sheet. Do you have suggestions?

Option Explicit

Sub PAY3()
Dim masterWB As Workbook
Dim newWB As Workbook
Dim filterRange As Range
Dim cell As Range
Dim ws As Worksheet
Dim newSheetName As String
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set masterWB = ThisWorkbook
With masterWB
With ActiveSheet
' create a temporary list of unique SALESPERSONS
.Range("B:B").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
' loop through each of the unique SALESPERSONS
' and filter on that value
Set filterRange = .Range("iv2:iv" &
Range("iv2").End(xlDown).Row)
For Each cell In filterRange
With .Range("A1")
' filter on column B (field:=2)
.AutoFilter Field:=2, Criteria1:=cell
newSheetName = cell.Value
' copy the current range, visible cells
.CurrentRegion.Copy
'Sheets(cell.Value).Add
Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = newSheetName
End With
Sheets(newSheetName).Select
Range("A4").Select
' paste the data
ActiveSheet.Paste

.AutoFilter
Application.CutCopyMode = False
End With
Next 'cell
' clear the temporary list of unique SALESPERSONS
filterRange.Offset(-1, 0).Resize( _
filterRange.Rows.Count + 1, filterRange.Columns.Count).Clear
End With
End With
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Thank You,
Elinor



*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

HELP. Can this be done easily? Save me HOURS of work.
 

At ActiveSheet.Paste, try
ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
That should give you only the data shown by the filter.

Ed

"Elinor Hartman" wrote in message
...
Hi Trevor,
I used your suggested code for Mr. B with minor changes. The difference
is I need to copy teh filtered data into a new worksheet within the
existing workbook and print it. It doesn't seem to paste the filtered
data into the new sheet. Do you have suggestions?

Option Explicit

Sub PAY3()
Dim masterWB As Workbook
Dim newWB As Workbook
Dim filterRange As Range
Dim cell As Range
Dim ws As Worksheet
Dim newSheetName As String
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set masterWB = ThisWorkbook
With masterWB
With ActiveSheet
' create a temporary list of unique SALESPERSONS
.Range("B:B").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
' loop through each of the unique SALESPERSONS
' and filter on that value
Set filterRange = .Range("iv2:iv" &
Range("iv2").End(xlDown).Row)
For Each cell In filterRange
With .Range("A1")
' filter on column B (field:=2)
.AutoFilter Field:=2, Criteria1:=cell
newSheetName = cell.Value
' copy the current range, visible cells
.CurrentRegion.Copy
'Sheets(cell.Value).Add
Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = newSheetName
End With
Sheets(newSheetName).Select
Range("A4").Select
' paste the data
ActiveSheet.Paste

.AutoFilter
Application.CutCopyMode = False
End With
Next 'cell
' clear the temporary list of unique SALESPERSONS
filterRange.Offset(-1, 0).Resize( _
filterRange.Rows.Count + 1, filterRange.Columns.Count).Clear
End With
End With
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Thank You,
Elinor



*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!