M
Max
I'm trying to use Ron's Sub Copy_To_Workbooks() - slightly customized (pasted
at bottom) - to splice the data below by Staff col values (col B) into
individual files. This works ok so far, but I need help to modify Ron's sub
to do 2 other steps in each individual file that's created. Thanks.
In sheet: C001,
I have data in cols A to H (headers in row1), eg:
CCode Staff Branch CIN Name Tel# Segmt AUM
001 RM01 Br001 111 Nam1 Tel1 Seg1 9400
001 RM01 Br001 112 Nam2 Tel2 Seg1 6700
001 RM02 Br001 113 Nam3 Tel3 Seg1 6100
001 RM02 Br001 114 Nam4 Tel4 Seg2 6600
001 RM03 Br002 115 Nam5 Tel5 Seg3 8500
001 RM03 Br002 116 Nam6 Tel6 Seg1 8800
001 RM04 Br002 117 Nam7 Tel7 Seg2 8600
etc
Required modifications
(1) In sheet: Action
I have created a template of 5 "Action" cols in A1:E2
These 5 cols are to be pasted into adjacent cols
to the right of the data in Sheet1 in each RM's file,
then filled down to the extent of data to the left (col B is the key)
CalledDate CallOutCome RespType SalesAmt SalesDate
01-Sep-08 Interested Fix Appt 5000 15-Sep-08
A2:E2 as above are just sample data showing what should be completed
In the sheet: Action, these are actually blank, except that CallOutCome &
RespType cols house simple DV lists (self contained, created in row2) while
CalledDate & SalesDate cols are pre-formatted to display dates as: dd-mmm-yy
(2) In sheet: Brief
there would be supportive info for the staff in textboxes, etc
This entire sheet is to be pasted as a new sheet into each RM's file, named:
Brief
So the final individual file that's created for each RM would contain
in Sheet1:
a) the spliced data in cols A to H, eg:
CCode Staff Branch CIN Name Tel# Segmt AUM
001 RM01 Br001 111 Nam1 Tel1 Seg1 9400
001 RM01 Br001 112 Nam2 Tel2 Seg1 6700
b) the 5 "Action" cols pasted/filled to the right of (a)
and a pasted new sheet: Brief
'-------- the sub that I'm trying out ----------
Sub Copy_To_Workbooks()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim MyPath As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long
'Name of the sheet with your data
Set ws1 = Sheets("C001") '<<< Change
'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:H" & Rows.Count)
'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 2
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = "D:\Max\Campaign"
'Application.DefaultFilePath
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False
'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value & FileExtStr, FileFormatNum
WSNew.Parent.Close False
'Close AutoFilter
ws1.AutoFilterMode = False
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
MsgBox "Look in " & foldername & " for the files"
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
at bottom) - to splice the data below by Staff col values (col B) into
individual files. This works ok so far, but I need help to modify Ron's sub
to do 2 other steps in each individual file that's created. Thanks.
In sheet: C001,
I have data in cols A to H (headers in row1), eg:
CCode Staff Branch CIN Name Tel# Segmt AUM
001 RM01 Br001 111 Nam1 Tel1 Seg1 9400
001 RM01 Br001 112 Nam2 Tel2 Seg1 6700
001 RM02 Br001 113 Nam3 Tel3 Seg1 6100
001 RM02 Br001 114 Nam4 Tel4 Seg2 6600
001 RM03 Br002 115 Nam5 Tel5 Seg3 8500
001 RM03 Br002 116 Nam6 Tel6 Seg1 8800
001 RM04 Br002 117 Nam7 Tel7 Seg2 8600
etc
Required modifications
(1) In sheet: Action
I have created a template of 5 "Action" cols in A1:E2
These 5 cols are to be pasted into adjacent cols
to the right of the data in Sheet1 in each RM's file,
then filled down to the extent of data to the left (col B is the key)
CalledDate CallOutCome RespType SalesAmt SalesDate
01-Sep-08 Interested Fix Appt 5000 15-Sep-08
A2:E2 as above are just sample data showing what should be completed
In the sheet: Action, these are actually blank, except that CallOutCome &
RespType cols house simple DV lists (self contained, created in row2) while
CalledDate & SalesDate cols are pre-formatted to display dates as: dd-mmm-yy
(2) In sheet: Brief
there would be supportive info for the staff in textboxes, etc
This entire sheet is to be pasted as a new sheet into each RM's file, named:
Brief
So the final individual file that's created for each RM would contain
in Sheet1:
a) the spliced data in cols A to H, eg:
CCode Staff Branch CIN Name Tel# Segmt AUM
001 RM01 Br001 111 Nam1 Tel1 Seg1 9400
001 RM01 Br001 112 Nam2 Tel2 Seg1 6700
b) the 5 "Action" cols pasted/filled to the right of (a)
and a pasted new sheet: Brief
'-------- the sub that I'm trying out ----------
Sub Copy_To_Workbooks()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim MyPath As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long
'Name of the sheet with your data
Set ws1 = Sheets("C001") '<<< Change
'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:H" & Rows.Count)
'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 2
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = "D:\Max\Campaign"
'Application.DefaultFilePath
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False
'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value & FileExtStr, FileFormatNum
WSNew.Parent.Close False
'Close AutoFilter
ws1.AutoFilterMode = False
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
MsgBox "Look in " & foldername & " for the files"
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub