Get templates files and copy data to it

F

franciz

Hi all,

I have a working sheet contains 15 columns and undetermine rows of data. I
have workbooks saved as group name, eg. "ABC Ltd" in a folder named under
group, eg. "ABC Ltd". These workbooks consist of about 5 -10 sheet templates
and are named under "group person "eg. "ABC John"

I need a macro to do the following :

1) Go to the correct folder and get to the workbook based on Column C of the
working sheet by using the first two or three characters, eg C2 value is "ABC
John"
The macro will go to Folder "ABC Ltd" and get the files "ABC Ltd"

2) Based on the value in Column C of the working sheet, get the relevant
sheet template. Both the sheet templates and the data in column C are named
the same,
eg. "ABC John"

3) copy certain the data in row 2 to specfic cells in the sheet templates.

working worksheet C2 to B13 of template
working worksheet G2 to B12 of the template
working worksheet F2 to B20 of the template
working worksheet J2 to B41 of the template
working worksheet A2 to B42 of the template
working worksheet O2 to B17 of the template

TIA and appreciate any help on this.

regards, francis
 
J

Joel

change folder name as required

Sub SaveToTemplet()

Folder = "c:\temp\"

With ActiveSheet
'get company name with employee name
CompName = .Range("C2")
'seperate company name from employee
CompName = Left(CompName, InStr(CompName, " ") - 1)
'add Ltd to Company name
CompName = CompName & "Ltd"

Set templet = Workbooks.Open(Filename:=Folder & CompName)
Set TempletSht = templet.ActiveSheet

.Range("C2").Copy Destination:=TempletSht.Range("B13")
.Range("G2").Copy Destination:=TempletSht.Range("B12")
.Range("F2").Copy Destination:=TempletSht.Range("B20")
.Range("J2").Copy Destination:=TempletSht.Range("B41")
.Range("A2").Copy Destination:=TempletSht.Range("B42")
.Range("O2").Copy Destination:=TempletSht.Range("B17")

End With

templet.Close savechanges:=True


End Sub
 
F

franciz

Hi Joel

Thanks for looking into this.
It give me an error message Run time error "1004"
" cannot access to "ABC Ltd", the document may be read-only or encrypted
with line highlighted :

Set templet = Workbooks.Open(Filename:=Folder & CompName)

I have check the workbook and it was not protected, both the path and the
files are
in the correct place.

Not sure where did this goes wrong.

regards, francis
 
J

Joel

There is a space missing in the file name. I have abcLtd.

from
CompName = CompName & "Ltd"
to
CompName = CompName & " Ltd"
 
F

franciz

Hi Joel

The macro does copy specific data to the sheet template except for B17which
give the result of #Ref, I believe this is due to the formula in column O
=F2/N2 in B17

Is it possible to have the macro look at column C and go to the specific
folders and get the sheet in the file which named the same as column C?

1) all the specific folders are saved in F:\MyProcess\xxxxx
where xxxxx is the folders' name that I need to access the files based on
the first 2 or 3 characters in column C of the working sheet

Eg. C2 have the value of ABC John
C3 have the value of ABC Mary
C4 have the value of NYC Maria

can the macro
1) open the sheet "ABC John" which it does now and copy the data and after
it is done
2) move to C3 and open the next sheet template which have "ABC Mary" under
"ABC Ltd" and copy the data.
3) then move to C4 and open NYC folder, look for "NYC Maria" and open it.
copy the
data to the sheet template of "NYC Maria"

thank you very much for assisting in this, I appreciate your effort very much

regards, francis
 
J

Joel

Try replaceing the copy statement with this code. This will not copy the
format. If you neeed formats I'll need to use pastespecial.

TempletSht.Range("B13") = .Range("C2").value
TempletSht.Range("B12") = .Range("G2").value
TempletSht.Range("B20") = .Range("F2").value
TempletSht.Range("B41") = .Range("J2").value
TempletSht.Range("B42") = .Range("A2").value
TempletSht.Range("B17") = .Range("O2").value
 
J

Joel

I made addional changes to move down column C. I'm not sure if the following
two lines are correct

Set templet = Workbooks.Open(Filename:=Folder & _
CompName & "\" & CompName.xls)
Set TempletSht = templet.Sheets(CompName & " " & PersonName)

The filename may be wrong. I think I got the sheet name correct in the
TempletSht line.





Sub SaveToTemplet()

Folder = "F:\MyProcess\"
Set SourceSht = ActiveSheet

With SourceSht
RowCount = 2
Do While Range("C" & RowCount) <> ""
'get company name with employee name
CompName = .Range("C" & RowCount)
'seperate company name from employee
PersonName = Trim(Mid(CompName, InStr(CompName, " ") + 1))
CompName = Left(CompName, InStr(CompName, " ") - 1)
'add Ltd to Company name
CompName = CompName & " Ltd"

Set templet = Workbooks.Open(Filename:=Folder & _
CompName & "\" & CompName.xls)
Set TempletSht = templet.Sheets(CompName & " " & PersonName)

TempletSht.Range("B13") = .Range("C" & RowCount).Value
TempletSht.Range("B12") = .Range("G" & RowCount).Value
TempletSht.Range("B20") = .Range("F" & RowCount).Value
TempletSht.Range("B41") = .Range("J" & RowCount).Value
TempletSht.Range("B42") = .Range("A" & RowCount).Value
TempletSht.Range("B17") = .Range("O" & RowCount).Value

templet.Close savechanges:=True

RowCount = RowCount + 1
Loop
End With

End Sub
 
F

franciz

Hi Joel

Thanks, it does copy correctly the value to the cells on sheet template.

However, is it possible for the macro to look at the next row and repeat the
same until the last empty cell in column C?

thank for your help in this.

regards, francis
 
J

Joel

Sorry I lost a period in the code

from
Do While Range("C" & RowCount) <> ""
to
Do While .Range("C" & RowCount) <> ""
 
J

Joel

found one more error. don't know why excel didn't give me an error

from
Set templet = Workbooks.Open(Filename:=Folder & _
CompName & "\" & CompName.xls)
Set templet = Workbooks.Open(Filename:=Folder & _
CompName & "\" & CompName & ".xls")
 
F

franciz

Hi Joel

Thank you very much for your effort. The macro produced an error message
" Run time error '9' : Subscript out of range " with this line highlighted

Set TempletSht = templet.Sheets(CompName & " " & personName)

thanks

regards, francis
 
J

Joel

The sheet name isn't in the workbook. Add this message box to help find
problem

MsgBox ("workbookName = " & CompName & ".xls" & Chr(10) & _
" Sheet Name : " & CompName & " " & PersonName)
Set TempletSht = templet.Sheets(CompName & " " & personName)
 
J

Joel

The sheet name isn't in the workbook. Add this message box to help find
problem

MsgBox ("workbookName = " & CompName & ".xls" & Chr(10) & _
" Sheet Name : " & CompName & " " & PersonName)
Set TempletSht = templet.Sheets(CompName & " " & personName)
 
J

Joel

The sheet name isn't in the workbook. Add this message box to help find
problem

MsgBox ("workbookName = " & CompName & ".xls" & Chr(10) & _
" Sheet Name : " & CompName & " " & PersonName)
Set TempletSht = templet.Sheets(CompName & " " & personName)
 
F

franciz

Hi Joel

This is great! thank you very much for your help.

Is it possible to create additional templates based on the last used
template of
the same name?
Currently the macro copy the data to the destinated cells of the templates
and the
last copied data remain there which will wipe out the earlier copied data.

As on some days, there more than one instances of the same name in column C,
eg C2,C6,C9 have the value "AB John". The templates will show the last copied
data in the template for C9 for the case of "AB John". I need all the copied
data to remain in the templates for printing, hence the need to create
additional templates by copying the template of "AB John" and add it to the
workbook if need.

Thanks

regards, francis
 
J

Joel

Instead of just closing the workbook I added a saveas, then cloded the
templet without any changes. The save as I add todays date to the filename.

DateString = Format(Date, "mm-dd-yyyy")
Templet.SaveAs Filename:=Folder & _
CompName & "\" & CompName & DateString & ".xls"
Templet.Close savechanges:=False
 
J

Joel

Try this code. It adds a version number to the filename (abc_1.xls). The
new code will check for all versions using the DIR() with a wildcard
(abc_*.xls). It will determine the previous hight version number and then
change the new file at the next hight revision. The code assume the original
file doesn't contain the underscore and version number

Version 1 abc.xls
Version 2 abc_2.xls
Version 3 abc_3.xls


Sub SaveToTemplet()

Folder = "F:\MyProcess\"
Set SourceSht = ActiveSheet

With SourceSht
RowCount = 2
Do While .Range("C" & RowCount) <> ""
'get company name with employee name
CompName = .Range("C" & RowCount)
'seperate company name from employee
PersonName = Trim(Mid(CompName, InStr(CompName, " ") + 1))
CompName = Left(CompName, InStr(CompName, " ") - 1)
'add Ltd to Company name
CompName = CompName & " Ltd"

FNamePrefix = Folder & CompName & "\" & CompName

Version = 0
'Look for all versions of the file using the wild card *
FName = Dir(FNamePrefix & "*.xls")
Do While FName <> ""
'If filname contain a underscore it is a version > 1
If InStr(FName, "_") > 1 Then
'remove all character before and including underscore
NewVersion = Mid(FName, InStr(FName, "_") + 1)
'remove the .xls and covert string to number
Version = Val(Left(NewVersion, InStr(NewVersion, ".") - 1))
Else
'no underscore in filename, then version is 1
NewVersion = 1
End If
If NewVersion > Version Then
Version = NewVersion
End If
FName = Dir()
Loop

Set Templet = Workbooks.Open(Filename:=FName & ".xls")
Set TempletSht = Templet.Sheets(CompName & " " & PersonName)

TempletSht.Range("B13") = .Range("C" & RowCount).Value
TempletSht.Range("B12") = .Range("G" & RowCount).Value
TempletSht.Range("B20") = .Range("F" & RowCount).Value
TempletSht.Range("B41") = .Range("J" & RowCount).Value
TempletSht.Range("B42") = .Range("A" & RowCount).Value
TempletSht.Range("B17") = .Range("O" & RowCount).Value

'save the file at the next higher revision number
Templet.SaveAs Filename:=FNamePrefix & "_" & (Version + 1) & "*.xls"
Templet.Close savechanges:=False

RowCount = RowCount + 1
Loop
End With

End Sub
 
J

Joel

I keep on missing things. This has a few improvements and corrections

Sub SaveToTemplet()

Folder = "F:\MyProcess\"
Set SourceSht = ActiveSheet

With SourceSht
RowCount = 2
Do While .Range("C" & RowCount) <> ""
'get company name with employee name
CompName = .Range("C" & RowCount)
'seperate company name from employee
PersonName = Trim(Mid(CompName, InStr(CompName, " ") + 1))
CompName = Left(CompName, InStr(CompName, " ") - 1)
'add Ltd to Company name
CompName = CompName & " Ltd"

CompanyFolder = Folder & CompName & "\"
FNamePrefix = CompanyFolder & CompName

Version = 0
'Look for all versions of the file using the wild card *
FName = Dir(FNamePrefix & "*.xls")
If FName = "" Then
MsgBox ("No Files exists for Company : " & CompName)
Else
Do While FName <> ""
'If filname contain a underscore it is a version > 1
If InStr(FName, "_") > 1 Then
'remove all character before and including underscore
NewVersion = Mid(FName, InStr(FName, "_") + 1)
'remove the .xls and covert string to number
Version = Val(Left(NewVersion, InStr(NewVersion, ".") - 1))
Else
'no underscore in filename, then version is 1
NewVersion = 1
End If
If NewVersion > Version Then
Version = NewVersion
End If
FName = Dir()
Loop
If Version = 1 Then
Set Templet = Workbooks.Open(Filename:=CompanyFolder & CompName
& ".xls")
Else
Set Templet = Workbooks.Open(Filename:=CompanyFolder & CompName
& "_" & Version & ".xls")
End If
Set TempletSht = Templet.Sheets(CompName & " " & PersonName)

TempletSht.Range("B13") = .Range("C" & RowCount).Value
TempletSht.Range("B12") = .Range("G" & RowCount).Value
TempletSht.Range("B20") = .Range("F" & RowCount).Value
TempletSht.Range("B41") = .Range("J" & RowCount).Value
TempletSht.Range("B42") = .Range("A" & RowCount).Value
TempletSht.Range("B17") = .Range("O" & RowCount).Value

'save the file at the next higher revision number
Templet.SaveAs Filename:=CompanyFolder & CompName & "_" & (Version
+ 1) & ".xls"
Templet.Close savechanges:=False

RowCount = RowCount + 1
End If
Loop
End With

End Sub
 
J

Joel

I did some more testing and found some minor errors. He is the code that
should work exactly the way you asked for it.


Sub SaveToTemplet()

Folder = "F:\MyProcess\"

Set SourceSht = ActiveSheet

With SourceSht
RowCount = 2
Do While .Range("C" & RowCount) <> ""
'get company name with employee name
CompName = .Range("C" & RowCount)
'seperate company name from employee
PersonName = Trim(Mid(CompName, InStr(CompName, " ") + 1))
CompName = Left(CompName, InStr(CompName, " ") - 1)
'add Ltd to Company name
CompName = CompName & " Ltd"

CompanyFolder = Folder & CompName & "\"
FNamePrefix = CompanyFolder & CompName

Version = 0
'Look for all versions of the file using the wild card *
FName = Dir(FNamePrefix & "*.xls")
If FName = "" Then
MsgBox ("No Files exists for Company : " & CompName)
Else
Do While FName <> ""
'If filname contain a underscore it is a version > 1
If InStr(FName, "_") > 1 Then
'remove all character before and including underscore
NewVersion = Mid(FName, InStr(FName, "_") + 1)
'remove the .xls and covert string to number
NewVersion = Val(Left(NewVersion, InStr(NewVersion, ".") - 1))
Else
'no underscore in filename, then version is 1
NewVersion = 1
End If
If NewVersion > Version Then
Version = NewVersion
End If
FName = Dir()
Loop
If Version = 1 Then
Set Templet = Workbooks.Open( _
Filename:=CompanyFolder & CompName & ".xls")
Else
Set Templet = Workbooks.Open( _
Filename:=CompanyFolder & _
CompName & "_" & Version & ".xls")
End If
Set TempletSht = Templet.Sheets(CompName & " " & PersonName)

TempletSht.Range("B13") = .Range("C" & RowCount).Value
TempletSht.Range("B12") = .Range("G" & RowCount).Value
TempletSht.Range("B20") = .Range("F" & RowCount).Value
TempletSht.Range("B41") = .Range("J" & RowCount).Value
TempletSht.Range("B42") = .Range("A" & RowCount).Value
TempletSht.Range("B17") = .Range("O" & RowCount).Value

'save the file at the next higher revision number
Templet.SaveAs Filename:= _
CompanyFolder & CompName & "_" & _
(Version + 1) & ".xls"
Templet.Close savechanges:=False

RowCount = RowCount + 1
End If
Loop
End With

End Sub
 

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

VBA Copying/Pasting problem when data is filtered 1
Finding, grouping, then copy/paste to new sheet 15
Macro to Copy certain values from different sheets to TIME Sheet 4
Comparing two columns in two different worksheet. 1
Find a value in a sheet and replace it with another value if it matches 8
Macro to create seperate sheets 1
Is it possible to get data from several word files having static format to one excel worksheet. 2
Data define and search function request? 6

Top