Copy/Paste Template to New Workbook

[Polo78 Lacoste]

I have a template with two worksheets, sheet1 with the actual template
which has about 20 vlookups and other formulas. Sheet2 contains the
range for the vlookups.

I need help to do a repetitive task of saving one template per file per
name as its own workbook. Sheet2 contains over 300 rows and each row
starting on A2 cell has a name of the file along with the corresponding
vlookup on sheet1 on cell D5.

Basically, the steps I manually do, every month.
1. Open the template above, and on Sheet1, their is a formula on D5
which has
=INDIRECT("Sheet2!$A2") as that is my first row of data.
All other formulas and vlookups depend on the data I changed in
Sheet1!$D5.
2. Copy/Paste values removing all formulas
3. Save it to the name of D5 cell on as a new workbook.
4. I then go back to D5 and change $A2 to $A3 and repeat steps 1 to 3,
etc until I reach end of my rows in Sheet2.

Any hard coding will be greatly appeciated.

Thank you.

Beginner in VBA

*** Sent via Developersdex http://www.developersdex.com ***

 

[joel]

Try this code. I open a dialog window so you can select the folder to put
the files. I create a new workbook with one sheet (a copy of your sheet 1).
Then put the filename (D5) into the new workbook, perform a copy -
pastespecial, and then save close the new workbook. The oringal Template
workbook alwaasy stays open but never gets changed.

Sub SaveBooks()

'set sheets to copy
Set OldBk = ThisWorkbook

Set objShell = CreateObject("Shell.Application")
Set fs = CreateObject("Scripting.FileSystemObject")


On Error Resume Next
Set objFolder = objShell.BrowseForFolder(&H0&, "Select Folder ", &H4001&)

If objFolder Is Nothing Then
MsgBox ("Cannot open directory - Exiting Macro")
Exit Sub
End If
On Error GoTo 0

Set oFolderItem = objFolder.Items.Item
Folder = oFolderItem.Path
If Right(Folder, 1) <> "\" Then
Folder = Folder & "\"
End If

With OldBk.Sheets("Sheet2")

RowCount = 2
Do While .Range("A" & RowCount) <> ""

'get filename
FName = .Range("A" & RowCount)
'Create new workbook with one sheet, template sheet 1
OldBk.Sheets("Sheet1").Copy
Set NewBk = ActiveWorkbook
Set NewSht = NewBk.Sheets("Sheet1")
NewSht.Range("D5") = FName
'change formulas to cells
NewSht.Cells.Copy
NewSht.Cells.PasteSpecial _
Paste:=xlPasteValues

'Save new file
NewBk.SaveAs Filename:=Folder & FName
NewBk.Close savechanges:=False
Loop
End With
End Sub

 

[Polo78 Lacoste]

Joel,
Thanks for the reply.... Awesome coding.. but I am having a problem with
the looping, it stays on the first record and when it tries to save the
file, as well as having a dialog prior to saving the first file, "Save
book2 with references to unsaved document?" Anyway to autosave it
without interaction? and fix the looping to move to the next row?

Thank you again.

Beginner in VBA.

*** Sent via Developersdex http://www.developersdex.com ***

 

[joel]

I just left out one line to increment the row. I think your problem with the
dialog box appearing is caused because the code kereps on saving the same
file over and over again. The code assumes the filename is on Sheet2 column
a.

Sub SaveBooks()

'set sheets to copy
Set OldBk = ThisWorkbook

Set objShell = CreateObject("Shell.Application")
Set fs = CreateObject("Scripting.FileSystemObject")


On Error Resume Next
Set objFolder = objShell.BrowseForFolder(&H0&, "Select Folder ", &H4001&)

If objFolder Is Nothing Then
MsgBox ("Cannot open directory - Exiting Macro")
Exit Sub
End If
On Error GoTo 0

Set oFolderItem = objFolder.Items.Item
Folder = oFolderItem.Path
If Right(Folder, 1) <> "\" Then
Folder = Folder & "\"
End If

With OldBk.Sheets("Sheet2")

RowCount = 2
Do While .Range("A" & RowCount) <> ""

'get filename
FName = .Range("A" & RowCount)
'Create new workbook with one sheet, template sheet 1
OldBk.Sheets("Sheet1").Copy
Set NewBk = ActiveWorkbook
Set NewSht = NewBk.Sheets("Sheet1")
NewSht.Range("D5") = FName
'change formulas to cells
NewSht.Cells.Copy
NewSht.Cells.PasteSpecial _
Paste:=xlPasteValues

'Save new file
NewBk.SaveAs Filename:=Folder & FName
NewBk.Close savechanges:=False
RowCount = RowCount + 1
Loop
End With
End Sub

 

[Polo78 Lacoste]

Joel,
I added the row increment and now works wonders. I also added a
Application.DisplayAlerts = False and Application.DisplayAlerts = True
before and after the While Loop to supress the "Save book2 with
references to unsaved document?" My last problem I have now is
refreshing cell Sheet!$J6 on my report. I have a function on this cell
to insert an image based on my Sheet1$C5 value but the image now does
not change, which should as its now looping from Sheet2 on A column. I
tried adding a "Range("C5:J6").Calculate" before pasting the values,
but that didn't do anything. Maybe I'm not using the calculate properly.
Hope you can help me solve this one.

Thank you in advance.

Newbie to VBA.

*** Sent via Developersdex http://www.developersdex.com ***

 

[joel]

first, this statement is not refereing to a valid sheet

Sheet!$J6

Are you miussing the sheet number before theh exlamation point?


If this is not the problem you need change the following statment for
testing to see what the proble is

from
NewSht.Cells.PasteSpecial _
Paste:=xlPasteValues

to
NewSht.Cells.PasteSpecial _
Paste:=xlPasteAll


Then look at the new workbook and see why the formula isn't working.

 

[Polo78 Lacoste]

Joel,
Cell J6 should refer to sheet1 as its a typo. So it should
read Sheet1!$J6.

The "Paste:=xlPasteValues" works fine on all newly saved
workbooks.. its the fact that the formula on Sheet1!$J6
does not change as this is not data but an image. So, I
need help on how to refresh the formula on this cell only,
so that when it goes to the next row from Sheet2 column $A,
the image changes. All other data changes except for the
image formula on Sheet1!$J6. If I manually change the cell
on Sheet1$C5, the cell image on Sheet1!$J6 changes
correctly.


Thank you in advance.

Newbie to VBA.

*** Sent via Developersdex http://www.developersdex.com ***

 

[Polo78 Lacoste]

Joel,
Cell J6 should refer to sheet1 as its a typo. So it should
read Sheet1!$J6.

The "Paste:=xlPasteValues" works fine on all newly saved
workbooks.. its the fact that the formula on Sheet1!$J6
does not change as this is not data but an image. So, I
need help on how to refresh the formula on this cell only,
so that when it goes to the next row from Sheet2 column $A,
the image changes. All other data changes except for the
image formula on Sheet1!$J6. If I manually change the cell
on Sheet1$C5, the cell image on Sheet1!$J6 changes
correctly.


Thank you in advance.

Newbie to VBA.

*** Sent via Developersdex http://www.developersdex.com ***

 

[joel]

Nothing in the orignal workbook changes with this code so you images won't
change. the code doesn't even activate any cells in the original workbook.
the code only copies sheet 1 in the original workbook into a new workbook and
saves the new workbook. Since nothing changes none of the formulas will get
updated.

 

[Polo78 Lacoste]

Joel,
Well thank you then for your help. Since the image has to update when I
change Sheet1$C5, (which is does when I manually create it), I guess I
wont be needing the function you created as it does not change the
image. Thank you for your time.


Newbie to VBA.

*** Sent via Developersdex http://www.developersdex.com ***

 

[joel]

I'n not sure the number of different macros yo are working with. Your
original request was to copy a emplate to a new workbook. This macro can
automatically change Sheet1$C5 every time it creates a new workbook. I just
need to know what is going into that location.

 

[Polo78 Lacoste]

Joel,
As mentioned on the first post, I have over 20 vlookups and
several functions, and all values changes based on cell
Sheet1!D5. Everything works flawless to this point and all
data is copied/pasted onto a new worksheet. The only
problem is that I have an image function on Sheet!J6 and
the function is added onto a module.

Inside the module, is the function in its native form:


Function ShowPicD(PicFile As String) As Boolean
'Same as ShowPic except deletes previous picture when
picfile changes
Dim AC As Range
Static P As Shape
On Error GoTo Done
Set AC = Application.Caller
If PicExists(P) Then
P.Delete
Else
'look for a picture already over cell
For Each P In ActiveSheet.Shapes
If P.Type = msoLinkedPicture Then
If P.Left >= AC.Left And P.Left < AC.Left +
AC.Width Then
If P.Top >= AC.Top And P.Top < AC.Top +
AC.Height Then
P.Delete
Exit For
End If
End If
End If
Next P
End If
Set P = ActiveSheet.Shapes.AddPicture(PicFile, True,
True, AC.Left, AC.Top, 200, 200)
ShowPicD = True
Exit Function
Done:
ShowPicD = False
End Function

Function PicExists(P As Shape) As Boolean
'Return true if P references an existing shape
Dim ShapeName As String
On Error GoTo NoPic
If P Is Nothing Then GoTo NoPic
ShapeName = P.Name
PicExists = True
NoPic:
PicExists = False
End Function


In Sheet1!J6, the formula is =showpicd("C:\PATH TO IMAGES\"
& D5 & ".jpg")

Note, there is nothing wrong with showpicd formula as it
works fine.

So having that said, it does not matter what function I
have on my cells, as long as it grabs the required data
from Sheet1C5. There are no other macros except the
"savebooks" which you created.



Thank you in advance.

Newbie to VBA.

*** Sent via Developersdex http://www.developersdex.com ***