Get templates files and copy data to it
Thank you! Joel
cheers, francis
"Joel" wrote:
This code will get unique items in column C and give a total.
Sub ItemsProcessed()
With ActiveSheet
Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
Set People = .Range("C2:C" & Lastrow)
If .FilterMode = True Then
.ShowAllData
End If
.Columns("C:C").AdvancedFilter _
Action:=xlFilterInPlace, Unique:=True
Set UniquePeople = People.SpecialCells(Type:=xlCellTypeVisible)
MessageString = ""
For Each Person In UniquePeople
CountItems = WorksheetFunction.CountIf(People, Person)
If MessageString = "" Then
MessageString = Person & " : " & CountItems
Else
MessageString = MessageString & Chr(13) & Person & " : " & CountItems
End If
Next Person
If .FilterMode = True Then
.ShowAllData
End If
End With
MsgBox (MessageString)
End Sub
"franciz" wrote:
Hi Joel
This is Fantastic!! You have been an excellent help.
Possible to have a message box that show the numbers of items
process for each name such as :
"Total for files process AB : 9. MY : 2, and so on" ?
How could I get started to learn coding in macro? I have a few good books on
this subject but doesn't seem to be able to get started on this.
thank you very much on all the help you have given. Appreciate very much!
cheers, francis
"Joel" wrote:
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
"Joel" wrote:
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
"franciz" wrote:
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
"Joel" wrote:
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)
"franciz" wrote:
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
"Joel" wrote:
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")
"franciz" wrote:
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
"Joel" wrote:
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
"franciz" wrote:
Hi Joel
|