How to copy rows into an Excel *template* with vba

G

Guest

My vba knowledge is very limited. Appreciate it if someone can show me how to
do this programmatically:

I have a master list of products which are grouped by Product Family ID. For
each Product Family ID, I need to copy all products rows that belong to it
from the master list into an Excel template and save it as a new workbook
with the Product Family ID appended in the name. I also need the Prod. Family
ID to appear in cell B2 of the Excel template.

Sample of Master list structure:
================================
ProductID | Product Name | Price per Unit | Product Family ID | Country


Sample Excel Template:
======================
There are 3 worksheets in the template. 1st & 3rd worksheet just contains
instructions & summary. The 2nd worksheet, "Product List", is the worksheet
where I want to copy the data in from the master list.

Product Family ID : ________ (cell B2)

ProductID | Product Name | Price per Unit | Product Family ID | Country |
Custom Calculation 1 | Custom Calculation 2 | Custom Calculation 3 | Formula
1 | Formula 2....

The Excel template contains macros and modules (the Custom calculation
fields in the template are custom vba functions, and there's a bunch of other
code under Worksheet_Change and in the "Product List" worksheet itself).

In addition, for each new workbook created:
1) The worksheet in the Excel template where we copy the products into needs
to be protected.
2) The vbaproject needs to be locked/protected too, to prevent others from
viewing the code and determine how some calculations are derived.

I'm desperate for help..... Manually copying and pasting to create 200
workbooks is tedious business :-(

Thanks,
Mikaela
 
G

Guest

Mikaela: Can you record a macro of the manual steps you perform so we can
modify the learned macro? The new macro should automatically run some of
your old macros as well as saving the files under different names. Review
the recorded macro and make any commments to help modifiy the code.

1) on worksheet - Tools Menu - Macro - Record New Macro
2) Perform the steps you normally would for running your macro and saving
the file.
 
G

Guest

Hi Joel,

Thanks for your reply.

The samples I posted before were simplified examples so I could explain what
I needed without confusing people too much.... As I'm recording the macro,
I'm posting the actual thing here:

Master list of products - Master.xls
Excel template - Template.xlt

Step-by-step of the manual process:
==========================

1. Open "Master.xls".

2. Create new workbook from "template.xlt". Choose disable macros when
opening.

3. In the new workbook, go to "Template" sheet:
- Unprotect this sheet (Password is "12345678").
- Select AT23:BT23 & drag down till row 28. (AT23:BT23 is basically the data
row with cells containing special formats, formulas, UDFs, etc. How many rows
that needs to be created with the drag down depends on how many products
there are with same ProductFamilyID (Column Z in "MasterList" sheet in
Master.xls). In this example it is 6 rows)

4. Go to "MasterList" sheet in "Master.xls", select & copy A2:O7. In the new
workbook, go to "Template" sheet & 'Paste Special - values' into A23:O28.

5. Go to "MasterList" sheet in "Master.xls", select & copy R2:Z7. In the new
workbook, go to "Template" sheet & 'Paste Special - values' into BL23:BT28.
Then HIDE columns BJ to BT.

5. Go to "footer" sheet in "Master.xls" & select & copy A1. In the new
workbook, sheet "Template", paste into the first cell of the next row after
the last data row. In this example, paste into A29.

6. In new workbook, sheet "Template", 'Paste Special - values' the
ProductFamilyID into Cell E1. ProductFamilyID. ProductFamilyID is in Z column
of "MasterList" sheet in "Master.xls".

7. Go to "amt tracking" sheet in "Master.xls". Column A is the
ProductFamilyID and Columns B to D is are number values associated with it.
For that ProductFamilyID (Column A) that is being worked on, I need to paste
the corresponding values (Column B to D) into the new workbook "Template"
sheet:
- On "amt tracking" sheet in "Master.xls", select & copy B2. Go to new
workbook, sheet "Template", and 'Paste Special - values' into B9.
- On "amt tracking" sheet in "Master.xls". select & copy C2. Go to new
workbook, sheet "Template", and 'Paste Special - values' into B10.
-. On "amt tracking" sheet in "Master.xls", select & copy D2. Go to new
workbook, sheet "Template", and 'Paste Special - values' into B11.

8. There's some open groupings (i.e. plus & minus signs) in the columns in
the template. Close the groupings in column Y, AG, AR, AX, BA, BE.

9. Protect the "Template" sheet (Password is "12345678").

10. Create new folder for the workbook recipient (A recipient can be linked
to more than one ProductFamilyID. The example here is "alanhudson"). Save
workbook as "template_(ProductFamilyID)_(RecipientName).xls" (example
ProductFamilyID is ZA1112C3, recipient is "AlanHudson").

ProductFamilyID is located in "MasterList" sheet in "Master.xls" Z column
(Z2 onwards), RecipientName in AA column (AA2 onwards).

11. Close the saved workbook.

Recorded macro code:
================
Code for Macro recording:
Sub Macro9()
'
' Macro9 Macro
'

'
Workbooks.Add Template:="C:\MasterList\template.xlt"
Cells.Select
ActiveSheet.Unprotect
Range("A23:BT23").Select
ActiveWindow.SmallScroll Down:=9
Selection.AutoFill Destination:=Range("A23:BT28"), Type:=xlFillDefault
Range("A23:BT28").Select
ActiveWindow.LargeScroll ToRight:=-3
Windows("Master.xls").Activate
Range("A2:O7").Select
Selection.Copy
Windows("template1").Activate
Range("A23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Windows("Master.xls").Activate
Range("R2:Z7").Select
Application.CutCopyMode = False
Selection.Copy
Windows("template1").Activate
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 24
ActiveWindow.ScrollColumn = 25
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 27
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 29
ActiveWindow.ScrollColumn = 30
ActiveWindow.ScrollColumn = 31
ActiveWindow.ScrollColumn = 32
ActiveWindow.ScrollColumn = 33
ActiveWindow.ScrollColumn = 34
ActiveWindow.ScrollColumn = 35
ActiveWindow.ScrollColumn = 36
ActiveWindow.ScrollColumn = 37
ActiveWindow.ScrollColumn = 38
ActiveWindow.ScrollColumn = 39
ActiveWindow.ScrollColumn = 40
ActiveWindow.ScrollColumn = 41
ActiveWindow.ScrollColumn = 42
ActiveWindow.ScrollColumn = 43
ActiveWindow.ScrollColumn = 44
ActiveWindow.ScrollColumn = 45
ActiveWindow.ScrollColumn = 46
ActiveWindow.ScrollColumn = 47
ActiveWindow.ScrollColumn = 48
ActiveWindow.ScrollColumn = 49
ActiveWindow.ScrollColumn = 50
ActiveWindow.ScrollColumn = 51
ActiveWindow.ScrollColumn = 52
ActiveWindow.ScrollColumn = 53
ActiveWindow.ScrollColumn = 54
ActiveWindow.ScrollColumn = 55
ActiveWindow.ScrollColumn = 56
ActiveWindow.ScrollColumn = 57
ActiveWindow.ScrollColumn = 58
ActiveWindow.ScrollColumn = 59
Range("BL23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveWindow.LargeScroll ToRight:=-3
ActiveWindow.SmallScroll Down:=3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 32
ActiveWindow.ScrollColumn = 37
ActiveWindow.ScrollColumn = 40
ActiveWindow.ScrollColumn = 41
ActiveWindow.ScrollColumn = 43
ActiveWindow.ScrollColumn = 48
ActiveWindow.ScrollColumn = 49
ActiveWindow.ScrollColumn = 48
ActiveWindow.ScrollColumn = 49
ActiveWindow.ScrollColumn = 50
ActiveWindow.ScrollColumn = 51
ActiveWindow.ScrollColumn = 52
ActiveWindow.ScrollColumn = 53
ActiveWindow.ScrollColumn = 54
ActiveWindow.ScrollColumn = 55
ActiveWindow.ScrollColumn = 56
ActiveWindow.ScrollColumn = 57
ActiveWindow.ScrollColumn = 55
ActiveWindow.ScrollColumn = 56
ActiveWindow.ScrollColumn = 57
Columns("BJ:BT").Select
Range("BJ13").Activate
Selection.EntireColumn.Hidden = True
ActiveWindow.LargeScroll ToRight:=-3
Windows("Master.xls").Activate
Sheets("footer").Select
Application.CutCopyMode = False
Selection.Copy
Windows("template1").Activate
Range("A29").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-15
Windows("Master.xls").Activate
Sheets("MasterList").Select
Range("Z2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("template1").Activate
Range("E3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Windows("Master.xls").Activate
Sheets("amt tracking").Select
Range("B2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("template1").Activate
Range("B9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Windows("Master.xls").Activate
Range("C2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("template1").Activate
Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Windows("Master.xls").Activate
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("template1").Activate
Range("B11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 27
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 29
ActiveWindow.ScrollColumn = 30
ActiveWindow.ScrollColumn = 29
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 27
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 24
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Cells.Select
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ChDir "C:\MasterList\alanhudson"
ActiveWorkbook.SaveAs Filename:= _
"C:\MasterList\alanhudson\template_ZA1112C3_AlanHudson.xls",
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
End Sub

This is very long, but I really appreciate any help!

Regards,
Mikaela
 
G

Guest

Try this code. Will not guarentee it will work the first try. there were
differences between your description and the macro and wasn't sure which was
correct. Macro contains both a templete and templete1 worksheet. The code
below use both templetes even though your description only had one.


Sub Macro9()
'
' Macro9 Macro
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
With ThisWorkbook.Sheets("MasterList")
LastRow = .Cells(Rows.Count, "Z").End(xlUp).Row
'Start Row is 1st row of a Product ID
startrow = 2
For RowCount = 2 To LastRow
If .Cells(RowCount, "Z") <> _
.Cells(RowCount + 1, "Z") Then

Prod_ID = .Cells(RowCount, "Z")
Prod_Count = RowCount - startrow + 1
Workbooks.Add _
Template:="C:\MasterList\template.xlt"
Set NewBook = ActiveWorkbook
Set NewTempl = NewBook.Sheets("Template")
Set NewTempl1 = NewBook.Sheets("Template1")
NewTempl.Select

NewTempl.Unprotect ("12345678")
.Activate
.Range("A23:BT23").Select
Selection.AutoFill _
Destination:= _
Range("A23:BT" & (23 + startrow - 1)), _
Type:=xlFillDefault
.Range("A" & startrow & ":O" & RowCount).Copy
NewTempl.Range("A23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("R" & startrow & ":Z" & RowCount).Copy

NewTempl1.Range("BL23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
NewTempl1.Columns("BJ:BT"). _
EntireColumn.Hidden = True

ThisWorkbook.Sheets("footer"). _
Range("A1").Copy _
Destination:= _
NewTempl1.Range("A" & (23 + Prod_Count))

.Range("Z" & RowCount).Copy
NewTempl1.Range("E3").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

With ThisWorkbook.Sheets("amt tracking")
.Range("B2").Copy
NewTempl1.Range("B9").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("C2").Copy
NewTempl1.Range("B10").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("D2").Copy
NewTempl1.Range("B11").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With

NewTempl1.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

NewTempl.Unprotect ("12345678")

recipient = .Range("AA" & RowCount)
Path = "C:\MasterList\"
Set folder = _
fs.GetFolder(Path)
Set mysubfolder = folder.subfolders
found = False
For Each file In mysubfolder
If file.Name = recipient Then
found = True
Exit For
End If
Next file
If found = False Then
mysubfolder.Add (recipient)
End If

NewBook.SaveAs Filename:= _
Path & recipient & "\template_" & _
Prod_ID & "_" & _
recipient & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False

startrow = RowCount + 1
End If
Next RowCount
End With
End Sub
 
G

Guest

I tested the code. It worked quite well & is VERY close to what I wanted to
do, except for a few parts (listed below). Am not sure I know why a template
& template1 worksheet is needed (I'm new at this, pls bear with me).

1. The autofill of A23:BT23 in the template worksheet in the new Template
workbook created from Template.xlt doesn't work for some reason. The format
doesn't autofill down to the number of product rows needed.
2. When copying values from "amt tracking" sheet in Master.xls into B9, B10
& B11 in template worksheet, the values that need to be copied are in columns
B, C & D *depending* on Product Family ID in column A. Example, if Product
Family ID is "XYZ" located in A13, then B13, C13 & D13 in "amt tracking"
sheet is copied into B9, B10 & B11 in the template worksheet.

Sorry if my explanation wasn't clear enough in the past.

Also, how do I modify the code so that:
1. In the template worksheet, after data is pasted from Master.xls (like in
the code snippet below), if value of the cell in column D equals "Asia
Pacific", then the corresponding cell in column E's unlocked & hidden
property must be false, and the cell background changed color to yellow.

..Range("A" & startrow & ":O" & RowCount).Copy
NewTempl.Range("A23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("R" & startrow & ":Z" & RowCount).Copy

NewTempl1.Range("BL23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
NewTempl1.Columns("BJ:BT"). _
EntireColumn.Hidden = True
Click to expand...

2. After the new workbook is saved, the workbook will be closed.

TIA
 
G

Guest

Try these changes. I think there was an error in statements like this

(23 + Prod_count - 1)

I added "-1". Also putting this change into the auto fill should correct
problem 1.

You instruction about hidden the cell in column E cannot be done. Single
cells can't be hidden, only rows or columns can be hidden. I unlocked the
cell and changed the background color to yellow.



Sub Macro9()
'
' Macro9 Macro
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
With ThisWorkbook.Sheets("MasterList")
LastRow = .Cells(Rows.Count, "Z").End(xlUp).Row
'Start Row is 1st row of a Product ID
startrow = 2
For RowCount = 2 To LastRow
If .Cells(RowCount, "Z") <> _
.Cells(RowCount + 1, "Z") Then

Prod_ID = .Cells(RowCount, "Z")
Prod_count = RowCount - startrow + 1
Workbooks.Add _
Template:="C:\MasterList\template.xlt"
Set NewBook = ActiveWorkbook
Set NewTempl = NewBook.Sheets("Template")
Set NewTempl1 = NewBook.Sheets("Template1")
NewTempl.Select

NewTempl.Unprotect ("12345678")
.Activate
.Range("A23:BT23").Select
Selection.AutoFill _
Destination:= _
Range("A23:BT" & (23 + Prod_count - 1)), _
Type:=xlFillDefault

.Range("A" & startrow & ":O" & RowCount).Copy
NewTempl.Range("A23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

' check for "Asia Pacific"
For RCount = 23 To (23 + Prod_count - 1)
If NewTempl.Range("D" & RCount) = "Asia Pacific" Then
Range("E" & RCount).Locked = False
Range("E" & RCount).Interior.ColorIndex = 6
End If
Next RCount

.Range("R" & startrow & ":Z" & RowCount).Copy
NewTempl1.Range("BL23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
NewTempl1.Columns("BJ:BT"). _
EntireColumn.Hidden = True

ThisWorkbook.Sheets("footer"). _
Range("A1").Copy _
Destination:= _
NewTempl1.Range("A" & (23 + Prod_count - 1))

.Range("Z" & RowCount).Copy
NewTempl1.Range("E3").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

With ThisWorkbook.Sheets("amt tracking")
'Find Prod_ID
Set c = .Columns("A:A").Find(what:=Prod_ID, LookIn:=xlValues)
.Range("B" & c.Row).Copy
NewTempl1.Range("B9").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("C" & c.Row).Copy
NewTempl1.Range("B10").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("D" & c.Row).Copy
NewTempl1.Range("B11").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With

NewTempl1.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

NewTempl.Unprotect ("12345678")

recipient = .Range("AA" & RowCount)
Path = "C:\MasterList\"
Set folder = _
fs.GetFolder(Path)
Set mysubfolder = folder.subfolders
found = False
For Each file In mysubfolder
If file.Name = recipient Then
found = True
Exit For
End If
Next file
If found = False Then
mysubfolder.Add (recipient)
End If

NewBook.SaveAs Filename:= _
Path & recipient & "\template_" & _
Prod_ID & "_" & _
recipient & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
NewBook.Close
startrow = RowCount + 1
End If
Next RowCount
End With
End Sub
 
G

Guest

I tested the code. Received an error and the execution stops midway, on the
error msgbox it just states "400" ?

Also, I was curious whether the autofill was working so I substituted your
code Range("A23:BT" & (23 + Prod_count - 1) in this part :
.Activate
.Range("A23:BT23").Select
Selection.AutoFill _
Destination:= _
Range("A23:BT" & (23 + Prod_count - 1)), _
Type:=xlFillDefault
Click to expand...

with a fixed range i.e. Range("A23:BT24"). The autofill doesn't work even if
the range is defined explicitly..... it doesn't autofill down.

TIA
 
G

Guest

I fixed the autofill. It was running the fill on the Master workbook instead
of the Templet. I wasn't able to repeat the 400 error. Can you specifiy
which line of code created the error. the error line should be highlighted
in yellow.

You may have to step through the code using the F8 key to help find the
problem. You can add variabbles into the watch window by highlighting the
variable and then right click the mouse. Then select add to watch. I need
more information to help fix this problem.


Sub Macro9()
'
' Macro9 Macro
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
With ThisWorkbook.Sheets("MasterList")
LastRow = .Cells(Rows.Count, "Z").End(xlUp).Row
'Start Row is 1st row of a Product ID
startrow = 2
For RowCount = 2 To LastRow
If .Cells(RowCount, "Z") <> _
.Cells(RowCount + 1, "Z") Then

Prod_ID = .Cells(RowCount, "Z")
Prod_count = RowCount - startrow + 1
Workbooks.Add _
Template:="C:\MasterList\template.xlt"
Set NewBook = ActiveWorkbook
Set NewTempl = NewBook.Sheets("Template")
Set NewTempl1 = NewBook.Sheets("Template1")
NewTempl.Activate

NewTempl.Unprotect ("12345678")

NewTempl.Range("A23:BT23").Select
Selection.AutoFill _
Destination:= _
NewTempl.Range("A23:BT" & (23 + Prod_count - 1)), _
Type:=xlFillDefault

.Range("A" & startrow & ":O" & RowCount).Copy
NewTempl.Range("A23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

' check for "Asia Pacific"
For RCount = 23 To (23 + Prod_count - 1)
If NewTempl.Range("D" & RCount) = "Asia Pacific" Then
Range("E" & RCount).Locked = False
Range("E" & RCount).Interior.ColorIndex = 6
End If
Next RCount

.Range("R" & startrow & ":Z" & RowCount).Copy
NewTempl1.Range("BL23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
NewTempl1.Columns("BJ:BT"). _
EntireColumn.Hidden = True

ThisWorkbook.Sheets("footer"). _
Range("A1").Copy _
Destination:= _
NewTempl1.Range("A" & (23 + Prod_count - 1))

.Range("Z" & RowCount).Copy
NewTempl1.Range("E3").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

With ThisWorkbook.Sheets("amt tracking")
'Find Prod_ID
Set c = .Columns("A:A").Find(what:=Prod_ID, LookIn:=xlValues)
.Range("B" & c.Row).Copy
NewTempl1.Range("B9").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("C" & c.Row).Copy
NewTempl1.Range("B10").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Range("D" & c.Row).Copy
NewTempl1.Range("B11").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With

NewTempl1.Protect _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

NewTempl.Unprotect ("12345678")

recipient = .Range("AA" & RowCount)
Path = "C:\MasterList\"
Set folder = _
fs.GetFolder(Path)
Set mysubfolder = folder.subfolders
found = False
For Each file In mysubfolder
If file.Name = recipient Then
found = True
Exit For
End If
Next file
If found = False Then
mysubfolder.Add (recipient)
End If

NewBook.SaveAs Filename:= _
Path & recipient & "\template_" & _
Prod_ID & "_" & _
recipient & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
NewBook.Close
startrow = RowCount + 1
End If
Next RowCount
End With
End Sub
 
G

Guest

Thanks for your quick reply. I used F8 to step thru the code and found that
this part caused the error is :

Selection.AutoFill _
Destination:= _
NewTempl.Range("A23:BT" & (23 + Prod_count - 1)), _
Type:=xlFillDefault

It throws out this error msgbox "Run-time error '1004'. Application-defined
or object-defined error". I added NewTempl & Product_count to the watch
window. In the watch window, the moment it reaches that part of code the
values in these variables turn to "<Out of context>".

When an explicitly defined range like "A23:BT27" is used, the autofill
works... most of the time. I'm not sure why it wouldn't work all the time
(I'm making a wild guess that Excel is confused with the selection since more
than one workbook is being handled :p)

As you can't reproduce the error, I wonder whether I did something on my
side. When you post your code I tweak it a teeny bit to suit me 100% (the
code that works for me is below verbatim). Also, a few days ago I changed
the name of the template sheet in the "Template.xlt" file from "Template" to
"PRODUCT TEMPLATE" and I also changed the code to cater to this. I wonder if
this modification is preventing the autofill from working.....

One last request... I need to change the protection properties to enable
outlining to work in the protected template sheet. I.e. something like this:

NewTempl.Protect Password:="12345678", userinterfaceonly:=True
NewTempl.EnableOutlining = True

If I use the above code, it throws an error at the autofill part of the code
(I was using explicitly defined range for the autofill while I was testing
this).

Appreciate your help.

TIA

=============================

Sub Macro9()
'
' Macro9 Macro
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
With ThisWorkbook.Sheets("MasterList")
LastRow = .Cells(Rows.Count, "Z").End(xlUp).Row
'Start Row is 1st row of a Product ID
startrow = 2
For RowCount = 2 To LastRow
If .Cells(RowCount, "Z") <> _
..Cells(RowCount + 1, "Z") Then

Prod_ID = .Cells(RowCount, "Z")
Prod_count = RowCount - startrow + 1
Workbooks.Add _
Template:="C:\MasterList\template.xlt"
Set NewBook = ActiveWorkbook
Set NewTempl = NewBook.Sheets("PRODUCT TEMPLATE")
Set NewTempl1 = NewBook.Sheets("PRODUCT TEMPLATE")
NewTempl.Activate

NewTempl.Unprotect ("12345678")

NewTempl.Range("A23:BT23").Select

'Commenting out because this part throws an error
'Selection.AutoFill _
Destination:= _
NewTempl.Range("A23:BT" & (23 + Prod_count - 1)), _
Type:=xlFillDefault

'In order to test entire macro, using explicit-defined range for autofill
Selection.AutoFill _
Destination:= _
NewTempl.Range("A23:BT27"), Type:=xlFillDefault

..Range("A" & startrow & ":O" & RowCount).Copy
NewTempl.Range("A23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

' check for "Asia Pacific"
For RCount = 23 To (23 + Prod_count - 1)
If NewTempl.Range("C" & RCount) = "Asia Pacific" Then
NewTempl.Range("E" & RCount).Locked = False
NewTempl.Range("E" & RCount).Interior.ColorIndex = 6
End If
Next RCount

..Range("R" & startrow & ":Z" & RowCount).Copy
NewTempl1.Range("BL23").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
NewTempl1.Columns("BJ:BT"). _
EntireColumn.Hidden = True

ThisWorkbook.Sheets("footer"). _
Range("A1").Copy _
Destination:= _
NewTempl1.Range("A" & (23 + Prod_count))

..Range("Z" & RowCount).Copy
NewTempl1.Range("E3").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

With ThisWorkbook.Sheets("amt tracking")
'Find Prod_ID
Set c = .Columns("A:A").Find(what:=Prod_ID, LookIn:=xlValues)
..Range("B" & c.Row).Copy
NewTempl1.Range("B9").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
..Range("C" & c.Row).Copy
NewTempl1.Range("B10").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
..Range("D" & c.Row).Copy
NewTempl1.Range("B11").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With

NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

recipient = .Range("AA" & RowCount)
Path = "C:\MasterList\"
Set folder = _
fs.GetFolder(Path)
Set mysubfolder = folder.subfolders
found = False
For Each file In mysubfolder
If file.Name = recipient Then
found = True
Exit For
End If
Next file
If found = False Then
mysubfolder.Add (recipient)
End If

NewBook.SaveAs Filename:= _
Path & recipient & "\template_" & _
Prod_ID & "_" & _
recipient & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
NewBook.Close
startrow = RowCount + 1
End If
Next RowCount
End With
End Sub
 
G

Guest

There is one place in the code where "23 + Prod_count " needs to be changed to
"23 + Prod_count - 1").

When it fails check the value of Prod_count. Your code uses 5 (23 + 5 - 1 =
27). The problem could be that my code is calculating a different value for
Prod_count.


The protection problem should be solved by unprotecting all features when
the code is run. Then at the end of the code protect only some of the
features.

from
NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True
to
NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
EnableOutlining = True
 
G

Guest

If you're referring to this part of the code,
ThisWorkbook.Sheets("footer"). _
Range("A1").Copy _
Destination:= _
NewTempl1.Range("A" & (23 + Prod_count))
Click to expand...

I changed the code to be like that because the "footer" value needs to
appear on the *next* line after the last product row. Example: 23 + 4 product
rows is A27. The product rows will occupy up to A26 while the "footer" value
will be on A27.

In the code that I used (23 + 5 - 1 = > 27), 5 is a constant value chosen at
random to temporarily substitute your autofill code that wasn't working. In
my master list the number of products is arbitrary. Your code is the one I
need because it counts the number of products per Product Family ID. I don't
think there's a no difference between your Prod_count & my Prod_count.....
I've checked by putting in a msgbox to prompt the value of "A23:BT" & (23 +
Prod_count - 1). Example: 23 + 4 product rows - 1 = "A23:BT26".

If the cause of the error can't be determined & fixed, is it possible to do
some kind of workaround ? At worst, I can fill column AB in the Masterlist
sheet with the number of product rows for each Product Family ID and let the
code read the Prod_count from there (Similar to how the code reads the
Recipients from column AA).

I tried the protection code but am receiving this error "Compile Error.
Expected: Named parameter".

TIA
 
G

Guest

Sorry, I meant "I don't think there's a difference between your Prod_count &
my Prod_count"

Thx
 
G

Guest

Protect only has these methods. Not sure which one alows outlining.

expression.Protect(Password, DrawingObjects, Contents, Scenarios,
UserInterfaceOnly, AllowFormattingCells, AllowFormattingColumns,
AllowFormattingRows, AllowInsertingColumns, AllowInsertingRows,
AllowInsertingHyperlinks, AllowDeletingColumns, AllowDeletingRows,
AllowSorting, AllowFiltering, AllowUsingPivotTables)

Try one more time the fixed code I gave you (see below)

NewTempl.Range("A23:BT23").Select
Selection.AutoFill _
Destination:= _
NewTempl.Range("A23:BT" & (23 + Prod_count - 1)), _
Type:=xlFillDefault

I don't believe that changing just the range in the above code makes a
differences in the code wroking and not working

NewTempl.Range("A23:BT27"), _
 
G

Guest

I agree with you. I tried it again, but the results are strangely the same :-(

I'm not sure if EnableOutlining is a method. But I have an example of it
working. There's a macro in Template.xlt with EnableOutlining already working
& it will allow a user to group & ungroup columns in the template sheet
(PRODUCT TEMPLATE) while the sheet is protected :

Private Sub Workbook_open()
With Worksheets("PRODUCT TEMPLATE")
.Protect Password:="12345678", userinterfaceonly:=True
.EnableOutlining = True
End With
End Sub

The above macro doesn't work in the new workbooks created with Macro 9 even
tho' the macro exists in the new workbooks. Maybe because in Macro 9 macro we
specified the new workbook's protection using

NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

I just don't know how to incorporate into Macro 9 so that all the new
workbooks will have the behavior of allowing the protected template sheet to
group/ungroup

TIA
 
G

Guest

Enable outlining is not a protection method. It is its own method.

from
NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
EnableOutlining = True

to
NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

NewTempl1.EnableOutlining = True

The only thing I can think of to fix the auto fill is the following:

FillRange = "A23:BT" & (23 + Prod_count - 1)
NewTempl.Range("A23:BT23").Select
Selection.AutoFill _
Destination:= _
NewTempl.Range(FillRange), _
Type:=xlFillDefault
 
G

Guest

I tried your latest autofill code and the results are still the same... it's
not working. (At this point, I wouldn't mind if I had to settle with a
workaround.)

For your enable.outlining code, to test it I had to temporarily use this
back :
Selection.AutoFill _
Destination:= _
NewTempl.Range("A23:BT27"), Type:=xlFillDefault

But when I applied this & ran the macro:
NewTempl1.Protect "12345678", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

NewTempl1.EnableOutlining = True

I get an error stating "Runtime error 1004. Application-defined or
object-defined error"......

I have to say I'm sorry for this frustrating problems.....
 
G

Guest

If you are still getting an error try this code to help isolate the problem.
It may be related to data on the templet. This code loops through the
columms A23:BT23 and tries to find which column data is causing the error

Sub test()

'
Set fs = CreateObject("Scripting.FileSystemObject")
'
With ThisWorkbook.Sheets("MasterList")
Workbooks.Add _
Template:="C:\MasterList\template.xlt"
Set NewBook = ActiveWorkbook
Set NewTempl = NewBook.Sheets("Template")
Set NewTempl1 = NewBook.Sheets("Template1")
NewTempl.Select

On Error GoTo err1
Prod_Count = 5
NewTempl.Unprotect ("12345678")
NewTempl.Activate
For Colcount = 1 To Range("BT23").Column
lastcelladdr = Cells(23, Colcount).Address
FromRange = "A23:" & lastcelladdr
lastcelladdr = Cells(27, Colcount).Address
ToRange = "A23:" & lastcelladdr
NewTempl.Range(FromRange).Select
Selection.AutoFill _
Destination:= _
NewTempl.Range(ToRange), _
Type:=xlFillDefault
Next Colcount
End With
Exit Sub
err1: MsgBox ("Error in cell " & lastcelladdr)
End Sub
 
G

Guest

Have run this and these are the results:

1st try - the msgbox pops up stating "Error in cell ". (strangely there was
no cell address appended to the msg).
2nd try - received this error "Run-time error '1004'. Application-defined or
object-defined error". The autofill ceases to run at column Q.

3rd try and onwards the code ran smoothly without any problem. The
inconsistency of the results is very peculiar as I didn't modify the code in
between any of the tries.....
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel Template Question... 2
loop to copy paste 3
VBA userform Vlookup Excel 1
Assistance with VBA and drop down list 0
Copy Template with Updated Values Each Time 0
Need thoughts on integration approach 1
display message box in excel(2003) using VBA word(2003) 0
Tranfer data from Excel to word (Docx) via VBA in Excel 5

Top