Hi All,

I have a table of data that looks some thing like this:

Column A Column B Column C
British Isles Salesman A 123
British Isles Salesman A 345
British Isles Salesman A 123456
British Isles Salesman B 9876
British Isles Salesman B 6789
British Isles Salesman C 7532
Europe Salesman 1 98475
Europe Salesman 1 9692
Europe Salesman 1 598310
Europe Salesman 2 6533
Europe Salesman 2 35678
Europe Salesman 3 9643
Europe Salesman 3 1423
Europe Salesman 4 7643
etc

What l want to do is create the following using the data in the table:

A workbook called 'Britsh Isles' with sheets for each salesman
containing each row of data
A workbook called 'Europe' with sheets for each salesman containing
each row of data

There will always be a variable number of Regions, Salesman & Data
rows

The workbooks should ideally be saved in the same directory as the
originating workbook.

Does anybody have any VBA code to achieve this or can they point me in
the right direction please?

All ideas gratefully received.

Regards

Michael

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim StartAt As Long
Dim wb As Workbook

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
StartAt = 1
For i = 2 To LastRow + 1

If .Cells(i, "A").Value < .Cells(i - 1, "A").Value Then

Set wb = Workbooks.Add
.Rows(StartAt).Resize(i - StartAt).Copy
wb.Worksheets(1).Range("A1")
wb.SaveAs .Path & Application.PathSeparator & .Cells(i - 1,
"A").Value
wb.Close
StartAt = 1
End If
Next i

Set wb = Nothing
End With

End Sub

--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)



"michael.beckinsale" wrote in message
...
Hi All,

I have a table of data that looks some thing like this:

Column A Column B Column C
British Isles Salesman A 123
British Isles Salesman A 345
British Isles Salesman A 123456
British Isles Salesman B 9876
British Isles Salesman B 6789
British Isles Salesman C 7532
Europe Salesman 1 98475
Europe Salesman 1 9692
Europe Salesman 1 598310
Europe Salesman 2 6533
Europe Salesman 2 35678
Europe Salesman 3 9643
Europe Salesman 3 1423
Europe Salesman 4 7643
etc

What l want to do is create the following using the data in the table:

A workbook called 'Britsh Isles' with sheets for each salesman
containing each row of data
A workbook called 'Europe' with sheets for each salesman containing
each row of data

There will always be a variable number of Regions, Salesman & Data
rows

The workbooks should ideally be saved in the same directory as the
originating workbook.

Does anybody have any VBA code to achieve this or can they point me in
the right direction please?

All ideas gratefully received.

Regards

Michael

Hi Bob,

Your a genius, it looks exactly like what l want.

Havn't tried it yet but will post back if any questions

Thank you very much

Regards

Michael

This works:

Option Base 1
Option Explicit

Sub SplitSalesData()
Dim DataArray(50000, 3) As Variant
Dim fnd As Double
Dim x As Double
Dim y As Double
Dim SlsPeople(500, 2) As Variant
Dim Sls As Double
Dim Found As Integer
Dim Z As Double
Dim W As Double
Dim Locations(500, 2) As Variant
Dim NbrLoc As Double

Sheets("MainDataSheet").Select '<--Change name to what it is
x = 1
Do While True
If Cells(x, 1).Value = Empty Then Exit Do
Found = 0
For y = 1 To Sls
If SlsPeople(y, 1) = Cells(x, 2).Value Then
Found = 1
Exit For
End If
Next
If Found = 0 Then
Sls = Sls + 1
SlsPeople(Sls, 1) = Cells(x, 2).Value
SlsPeople(Sls, 2) = Cells(x, 1).Value
End If

Found = 0
For y = 1 To NbrLoc
If Locations(y, 1) = Cells(x, 1).Value Then
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrLoc = NbrLoc + 1
Locations(NbrLoc, 1) = Cells(x, 1).Value
End If


fnd = fnd + 1
For y = 1 To 3
DataArray(fnd, y) = Cells(x, y).Value
Next
x = x + 1
Loop

Dim MyEntries As String
Dim NewWks As Worksheet



For W = 1 To NbrLoc
Workbooks.Add Template:="Workbook"
MyEntries = ActiveWorkbook.Name
For y = 1 To Sls
If SlsPeople(y, 2) = Locations(W, 1) Then
Z = 1
Set NewWks = Worksheets.Add
NewWks.Name = SlsPeople(y, 1)
Cells(1, 1).Value = "Salesman"
Cells(1, 2).Value = "Amount"
For x = 1 To fnd
If DataArray(x, 2) = SlsPeople(y, 1) Then
Z = Z + 1
Cells(Z, 1).Value = DataArray(x, 2)
Cells(Z, 2).Value = DataArray(x, 3)
End If
Next
End If
Next
ActiveWorkbook.SaveAs Filename:="C:\TEMP\" & Locations(W, 1) & ".xlsx",
FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False

Next
End Sub


"michael.beckinsale" wrote:

Hi All,

I have a table of data that looks some thing like this:

Column A Column B Column C
British Isles Salesman A 123
British Isles Salesman A 345
British Isles Salesman A 123456
British Isles Salesman B 9876
British Isles Salesman B 6789
British Isles Salesman C 7532
Europe Salesman 1 98475
Europe Salesman 1 9692
Europe Salesman 1 598310
Europe Salesman 2 6533
Europe Salesman 2 35678
Europe Salesman 3 9643
Europe Salesman 3 1423
Europe Salesman 4 7643
etc

What l want to do is create the following using the data in the table:

A workbook called 'Britsh Isles' with sheets for each salesman
containing each row of data
A workbook called 'Europe' with sheets for each salesman containing
each row of data

There will always be a variable number of Regions, Salesman & Data
rows

The workbooks should ideally be saved in the same directory as the
originating workbook.

Does anybody have any VBA code to achieve this or can they point me in
the right direction please?

All ideas gratefully received.

Regards

Michael

Hi Bob,

Unfortunately the code doesn't work properly. Probably my explanation
of what was wanted.

1) Code does not allow for column header
2) Code does not create new sheet for each for each salesman and name
sheet as salesman
3) wb.SaveAs .Path etc errors out

Can you help rectify this please

Regards

Michael

Public Sub ProcessData()
Dim Wb As Workbook
Dim rngRegion As Range
Dim i As Long
Dim LastRow As Long
Dim StartAt As Long
Dim NumSheets As Long
Dim EvalFormula As String

Const Formula As String = _
"SUMPRODUCT((B<start:B<end<"""")/COUNTIF(B<start:B<end,B<start:B<end&""""))"

NumSheets = Application.SheetsInNewWorkbook
With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
StartAt = 2
i = 2
For i = 3 To LastRow + 1

If .Cells(i, "A").Value < .Cells(i - 1, "A").Value Then

EvalFormula = Replace(Formula, "<start", StartAt)
EvalFormula = Replace(EvalFormula, "<end", i - 1)
EvalFormula = Replace(EvalFormula, "<region",
..Cells(StartAt, "A"))
Application.SheetsInNewWorkbook = .Evaluate(EvalFormula)
Set Wb = Workbooks.Add
.Rows(StartAt).Resize(i - StartAt).Copy _
Wb.Worksheets(1).Range("A2")
.Rows(1).Copy Wb.Worksheets(1).Range("A1")
Call SplitSheets(Wb, StartAt - i)
Wb.SaveAs .Parent.Path & Application.PathSeparator &
..Cells(i - 1, "A").Value
Wb.Close
StartAt = i
End If
Next i

Set Wb = Nothing
End With

Application.SheetsInNewWorkbook = NumSheets
End Sub

Private Sub SplitSheets(ByRef Wb As Workbook, ByVal NumRows As Long)
Dim SheetNum As Long
Dim StartAt As Long
Dim DeleteFrom As Long
Dim i As Long

With Wb.Worksheets(1)

i = 2
'let's leave the first Salesman on sheet 1
Do
i = i + 1
Loop Until .Cells(i, "B").Value < .Range("B2").Value
.Name = .Range("B2").Value
.Columns("A:C").AutoFit

SheetNum = 2
DeleteFrom = i
StartAt = i
Do
i = i + 1
If .Cells(i - 1, "A").Value < "" Then

If .Cells(i, "B").Value < .Cells(StartAt, "B").Value Then

.Rows(StartAt).Resize(i - StartAt).Copy _
Wb.Worksheets(SheetNum).Range("A2")
.Rows(1).Copy Wb.Worksheets(SheetNum).Range("A1")
Wb.Worksheets(SheetNum).Name = .Cells(StartAt,
"B").Value
Wb.Worksheets(SheetNum).Columns("A:C").AutoFit
StartAt = i
SheetNum = SheetNum + 1
End If
End If
Loop Until .Cells(i - 1, "A").Value < .Range("A2").Value
.Rows(DeleteFrom).Resize(i - DeleteFrom).Delete
End With
End Sub




--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"michael.beckinsale" wrote in message
...
Hi Bob,

Unfortunately the code doesn't work properly. Probably my explanation
of what was wanted.

1) Code does not allow for column header
2) Code does not create new sheet for each for each salesman and name
sheet as salesman
3) wb.SaveAs .Path etc errors out

Can you help rectify this please

Regards

Michael

Hi Bob,

Thats some coding, not sure l fully understand it, l will give it a
try and see if it is more efficient than what l came up with (l'm sure
it will be!)

The code l am using is posted below. Would you be kind enough to give
it a quick 'once over' to ensure that l have not overlooked some
eventuality l haven't thiught of?

Public Sub ProcessData()

Dim i As Long
Dim r As Long
Dim LastRow As Long
Dim StartAt As Long
Dim wb As Workbook
Dim sh As String

Application.ScreenUpdating = False

With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
StartAt = 1
For i = 2 To LastRow
If .Cells(i, "C").Value < .Cells(i - 1, "C").Value Then
Set wb = Workbooks.Add
End If
If .Cells(i, "A").Value < .Cells(i - 1, "A").Value Then
sh = .Cells(i, "A").Value
wb.Sheets.Add
wb.ActiveSheet.Name = sh
.Rows(1).Copy wb.Worksheets(sh).Range("A1")
r = 2
End If
.Rows(i).Copy wb.Worksheets(sh).Range("A" & r)
r = r + 1
If .Cells(i, "C").Value < .Cells(i + 1, "C").Value Then
wb.SaveAs ThisWorkbook.Path & Application.PathSeparator
& .Cells(i, "C").Value
wb.Close
End If
Next i
Set wb = Nothing
End With


End Sub

Regards

Michael

A quick look at this suggests that you create a new workbook per salesman. I
thought you wanted a new workbook per region, new sheet per salesman.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"michael.beckinsale" wrote in message
...
Hi Bob,

Thats some coding, not sure l fully understand it, l will give it a
try and see if it is more efficient than what l came up with (l'm sure
it will be!)

The code l am using is posted below. Would you be kind enough to give
it a quick 'once over' to ensure that l have not overlooked some
eventuality l haven't thiught of?

Public Sub ProcessData()

Dim i As Long
Dim r As Long
Dim LastRow As Long
Dim StartAt As Long
Dim wb As Workbook
Dim sh As String

Application.ScreenUpdating = False

With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
StartAt = 1
For i = 2 To LastRow
If .Cells(i, "C").Value < .Cells(i - 1, "C").Value Then
Set wb = Workbooks.Add
End If
If .Cells(i, "A").Value < .Cells(i - 1, "A").Value Then
sh = .Cells(i, "A").Value
wb.Sheets.Add
wb.ActiveSheet.Name = sh
.Rows(1).Copy wb.Worksheets(sh).Range("A1")
r = 2
End If
.Rows(i).Copy wb.Worksheets(sh).Range("A" & r)
r = r + 1
If .Cells(i, "C").Value < .Cells(i + 1, "C").Value Then
wb.SaveAs ThisWorkbook.Path & Application.PathSeparator
& .Cells(i, "C").Value
wb.Close
End If
Next i
Set wb = Nothing
End With


End Sub

Regards

Michael