I regularly need to split a report held in a single worksheet into new
separate workbooks and I use the code below which I have modified from
one I found on the exceltips website.

My problem is I ofen need to split by a column other than A.

For example columns A-C would be "Business", "Region", "Team" and I need
a new workbook for each "Team" to send out to the relevant manager.

Currently I just move column C (Team) to before column A then run the
macro which works fine but I would rather have a macro that would be
more generic and allow me to specify the column to split by.

I know I have the basics there and have managed to add in various extra
checks and options and I am coming close to the macro I need but I have
come to the limit of my knowledge.

Could any of you experts out there please help me. TIA


-----
Sub SplitDataToNewWorkbooks()

Dim LMainWB As String ' Name of the workbook that contains the data
Dim LNewWB As String ' Name of new workbook that will contain the
copied data
Dim LRow As Integer
Dim LContinue As Boolean

Dim LCol As String
Dim LColAMaster As String
Dim LColATest As String

Dim LWBCount As Integer
Dim LMsg As String

Dim LPath As String 'File path whre new files are created
Dim LFilename As String 'Name of new file
Dim LPrefix As String ' Optional Prefix to prepend to new filename
Dim LSuffix As String ' Optional Suffix to append to new filename


Dim LColAValue As String

Dim LCopyCount As Integer

Application.ScreenUpdating = False

'Input criteria for splitting

'Path to save all new workbooks to
LPath = InputBox("Enter the folder to save new workbooks to followed
by a \" & Chr(10) & _
"eg H:\USER\", "Save Directory")

'Check for no path entered
If LPath = "" Then
MsgBox ("No path entered. Exiting macro")
Exit Sub
End If

'Check if directory exists
If Not (FileFolderExists(LPath)) Then
MsgBox "Folder " & LPath & " does not exist!" & Chr(10) _
& "Please create folder then re-run macro"
Exit Sub
End If

'Check path ends with a \ else add
If Right(LPath, 1) < "\" Then
LPath = LPath & "\"
End If

'Add optional prefix to filename
LPrefix = InputBox("Enter optional prefix for filename..." & Chr(10)
& _
"Leave Empty if not required" & Chr(10) & _
"A space will automatically be added after any prefix entered",
"Optional Prefix")
If LPrefix < "" Then LPrefix = LPrefix & " "

'Add optional Suffix to filename
LSuffix = InputBox("Enter optional suffix for filename..." & Chr(10)
& _
"Leave Empty if not required" & Chr(10) & _
"A space will automatically be added before any prefix entered",
"Optional Suffix")
If LSuffix < "" Then LSuffix = " " & LSuffix

'Column to split by
LCol = InputBox("Enter letter of column to split by...", "Column to
split by")


'Retrieve name of the workbook that contains the data
LMainWB = ActiveWorkbook.Name

'Initialize variables
LContinue = True
LRow = 2
LWBCount = 0

'Start comparing with cell A2
LColAMaster = CStr(LCol) & "2"

'Loop through all column to be sorted by values until a blank cell
is found
While LContinue = True

LRow = LRow + 1
LColATest = LCol & CStr(LRow)

'Found a blank cell, do not continue
If Len(Range(LColATest).Value) = 0 Then
LContinue = False
End If

'Value in column to be sorted by
LColAValue = Range(LColAMaster).Value

'Found occurrence that did not match, copy data to new workbook
If LColAValue < Range(LColATest).Value Then

'Copy headings
Range("1:1").Select
Selection.Copy

'Add new workbook and paste headings into new workbook
Workbooks.Add
LNewWB = ActiveWorkbook.Name
ActiveSheet.Paste
Range("A1").Select

'Copy data from columns A - IV
Windows(LMainWB).Activate
Range(LColAMaster & ":IV" & CStr(LRow - 1)).Select
Selection.Copy

'Paste results
Windows(LNewWB).Activate
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

'Save workbook with name from column A plus any
Prefix/Suffix and then close workbook
LFilename = LPath & LPrefix & LColAValue & LSuffix & ".xls"
'If Dir(LFilename) < "" Then Kill LFilename

'Check if filename exists and rename new file
LCopyCount = 1
While (FileFolderExists(LFilename))
LFilename = LPath & LPrefix & LColAValue & LSuffix &
"-" & LCopyCount & ".xls"
LCopyCount = LCopyCount + 1
Wend

ActiveWorkbook.SaveAs FileName:=LFilename
ActiveWorkbook.Close

'Go back to Main sheet and continue where left off
Windows(LMainWB).Activate
LColAMaster = LCol & CStr(LRow)

'Keep track of the number of workbooks that have been
created
LWBCount = LWBCount + 1

End If

Wend

Application.ScreenUpdating = True

Range("A1").Select
Application.CutCopyMode = False

LMsg = "Copy has completed. " & LWBCount & " new workbooks have been
created."
LMsg = LMsg & Chr(10) & "You can find them in the following
directory:" & Chr(10) & LPath

MsgBox LMsg

End Sub

------
Public Function FileFolderExists(strFullPath As String) As Boolean
'Check if a file or folder exists

If Not Dir(strFullPath, vbDirectory) = vbNullString Then
FileFolderExists = True

End Function

Hi Chris

I have a example here
http://www.rondebruin.nl/copy5.htm#workbook

You can change
FieldNum = 1

You can use for example
FieldNum = Application.InputBox(prompt:="Sample", Type:=1)

a new workbook for each "Team" to send out to the relevant manager.
See also this macro to mail also
http://www.rondebruin.nl/mail/folder3/row2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Chris" wrote in message . 109.145...
I regularly need to split a report held in a single worksheet into new
separate workbooks and I use the code below which I have modified from
one I found on the exceltips website.

My problem is I ofen need to split by a column other than A.

For example columns A-C would be "Business", "Region", "Team" and I need
a new workbook for each "Team" to send out to the relevant manager.

Currently I just move column C (Team) to before column A then run the
macro which works fine but I would rather have a macro that would be
more generic and allow me to specify the column to split by.

I know I have the basics there and have managed to add in various extra
checks and options and I am coming close to the macro I need but I have
come to the limit of my knowledge.

Could any of you experts out there please help me. TIA


-----
Sub SplitDataToNewWorkbooks()

Dim LMainWB As String ' Name of the workbook that contains the data
Dim LNewWB As String ' Name of new workbook that will contain the
copied data
Dim LRow As Integer
Dim LContinue As Boolean

Dim LCol As String
Dim LColAMaster As String
Dim LColATest As String

Dim LWBCount As Integer
Dim LMsg As String

Dim LPath As String 'File path whre new files are created
Dim LFilename As String 'Name of new file
Dim LPrefix As String ' Optional Prefix to prepend to new filename
Dim LSuffix As String ' Optional Suffix to append to new filename


Dim LColAValue As String

Dim LCopyCount As Integer

Application.ScreenUpdating = False

'Input criteria for splitting

'Path to save all new workbooks to
LPath = InputBox("Enter the folder to save new workbooks to followed
by a \" & Chr(10) & _
"eg H:\USER\", "Save Directory")

'Check for no path entered
If LPath = "" Then
MsgBox ("No path entered. Exiting macro")
Exit Sub
End If

'Check if directory exists
If Not (FileFolderExists(LPath)) Then
MsgBox "Folder " & LPath & " does not exist!" & Chr(10) _
& "Please create folder then re-run macro"
Exit Sub
End If

'Check path ends with a \ else add
If Right(LPath, 1) < "\" Then
LPath = LPath & "\"
End If

'Add optional prefix to filename
LPrefix = InputBox("Enter optional prefix for filename..." & Chr(10)
& _
"Leave Empty if not required" & Chr(10) & _
"A space will automatically be added after any prefix entered",
"Optional Prefix")
If LPrefix < "" Then LPrefix = LPrefix & " "

'Add optional Suffix to filename
LSuffix = InputBox("Enter optional suffix for filename..." & Chr(10)
& _
"Leave Empty if not required" & Chr(10) & _
"A space will automatically be added before any prefix entered",
"Optional Suffix")
If LSuffix < "" Then LSuffix = " " & LSuffix

'Column to split by
LCol = InputBox("Enter letter of column to split by...", "Column to
split by")


'Retrieve name of the workbook that contains the data
LMainWB = ActiveWorkbook.Name

'Initialize variables
LContinue = True
LRow = 2
LWBCount = 0

'Start comparing with cell A2
LColAMaster = CStr(LCol) & "2"

'Loop through all column to be sorted by values until a blank cell
is found
While LContinue = True

LRow = LRow + 1
LColATest = LCol & CStr(LRow)

'Found a blank cell, do not continue
If Len(Range(LColATest).Value) = 0 Then
LContinue = False
End If

'Value in column to be sorted by
LColAValue = Range(LColAMaster).Value

'Found occurrence that did not match, copy data to new workbook
If LColAValue < Range(LColATest).Value Then

'Copy headings
Range("1:1").Select
Selection.Copy

'Add new workbook and paste headings into new workbook
Workbooks.Add
LNewWB = ActiveWorkbook.Name
ActiveSheet.Paste
Range("A1").Select

'Copy data from columns A - IV
Windows(LMainWB).Activate
Range(LColAMaster & ":IV" & CStr(LRow - 1)).Select
Selection.Copy

'Paste results
Windows(LNewWB).Activate
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

'Save workbook with name from column A plus any
Prefix/Suffix and then close workbook
LFilename = LPath & LPrefix & LColAValue & LSuffix & ".xls"
'If Dir(LFilename) < "" Then Kill LFilename

'Check if filename exists and rename new file
LCopyCount = 1
While (FileFolderExists(LFilename))
LFilename = LPath & LPrefix & LColAValue & LSuffix &
"-" & LCopyCount & ".xls"
LCopyCount = LCopyCount + 1
Wend

ActiveWorkbook.SaveAs FileName:=LFilename
ActiveWorkbook.Close

'Go back to Main sheet and continue where left off
Windows(LMainWB).Activate
LColAMaster = LCol & CStr(LRow)

'Keep track of the number of workbooks that have been
created
LWBCount = LWBCount + 1

End If

Wend

Application.ScreenUpdating = True

Range("A1").Select
Application.CutCopyMode = False

LMsg = "Copy has completed. " & LWBCount & " new workbooks have been
created."
LMsg = LMsg & Chr(10) & "You can find them in the following
directory:" & Chr(10) & LPath

MsgBox LMsg

End Sub

------
Public Function FileFolderExists(strFullPath As String) As Boolean
'Check if a file or folder exists

If Not Dir(strFullPath, vbDirectory) = vbNullString Then
FileFolderExists = True

End Function

Thanks for your help, but I managed to get it to work now

The bit:

'Copy data from columns A - IV
Windows(LMainWB).Activate
Range(LColAMaster & ":IV" & CStr(LRow - 1)).Select
Selection.Copy

was only copying from the column to split by across to column IV eg if you
split by column C then it would select C2:IV10 not A2:IV10

Changed it to:

Range("A" & Right(LColAMaster, Len(LColAMaster) - 1) & ":IV" & CStr(LRow -
1)).Select

Think this will only work if the column to split by is in A to Z and not eg
AB but it is unlikely I'll need to split by a column that far across
anyway.

Did use the tip of using PasteSpecial rather than Paste from your example
to keep the formatting of column widths etc so thanks for that

Cheers
Chris