Any ideas on how to do this?

[michael.beckinsale]

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

 

[Bob Phillips]

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)

 

[Mike H.]

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]

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

 

[michael.beckinsale]

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

 

[Bob Phillips]

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]

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

 

[Bob Phillips]

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]

Hi Bob,

I structured my example as Region, Salesman, Data because it seems
more logical and easier for the reader to understand what was
required.

In practice the 'database' columns appear as Salesman, Region, Data
with columns preceding, between and after.

You are correct that l want a new workbook for each Region and a sheet
for each salesman.

My code seems to be working fine but with a couple of minor irritants:

1) I end up with unwanted sheets ie sheet1, sheet2, sheet3
2) If the region name has an illegal character (/?\!*<>:|) the code
errors out

Any idea how to overcome these shortcomings?

For the moment l have decided to stick with my code as when l have to
re-visit during development l will be able to follow it. When l get
time to fully study & understand your code l may replace it.

Many thanks for your help & patience so far. Hope you help with the
outstanding issues.

Regards

Michael

 

[Bob Phillips]

Have you hanged the order of the data. This bombs on me, after creating
workbook called 123.xls

--
---
HTH

Bob


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

 

[michael.beckinsale]

Hi Bob,

For the code to work as posted, using the data given as an example
then column A would have to be in Column C, Column B would have to be
in Column A and Column C can be in any other column.

ie in practice my regional data is in column C, salesman data in
column A and data is in other columns

Regards

Michael

 

[Bob Phillips]

Public Sub ProcessData()

Dim i As Long, j 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
Application.DisplayAlerts = 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
For j = wb.Worksheets.Count To wb.Worksheets.Count - 2
Step -1
wb.Worksheets(j).Delete
Next j
wb.SaveAs ThisWorkbook.Path & _
Application.PathSeparator & ValidFileName(.Cells(i,
"C").Value)
wb.Close
End If
Next i
Set wb = Nothing
Application.DisplayAlerts = True
End With
End Sub

Function ValidFileName(ByVal TheFileName As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
RegEx.Pattern = "[\\/:\*\?""<>\|]"
ValidFileName = RegEx.Replace(TheFileName, "")
Set RegEx = Nothing
End Function

--
---
HTH

Bob


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

 

[michael.beckinsale]

Hi Bob,

Many thanks for your help.

Sheets1, Sheets2 etc now being deleted.

Function to remove illegal characters is ace! It will be going into my
code library.

Again many thanks

Michael