 |
 | Home | Contact Us | FAQ | Search & Site Map | Link to Us |
 | Sign In | Join | Other 45 Sites in Network |
| HomeDiscussionsAccessExcelInfoPathOutlookPowerPointPublisherWordDirectoryUser Groups Related Topics Outlook ExpressInternet ExplorerWindowsMS Server ProductsMore Topics ... |
MS Office Forum / Excel / Programming / May 2008Get templates files and copy data to it
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 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 > Hi all, > [quoted text clipped - 27 lines] > > regards, francis 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 > change folder name as required > [quoted text clipped - 57 lines] > > > > regards, francis There is a space missing in the file name. I have abcLtd. from CompName = CompName & "Ltd" to CompName = CompName & " Ltd" > Hi Joel > [quoted text clipped - 74 lines] > > > > > > regards, francis You also need to change the Folder to the folder you are using. > Hi Joel > [quoted text clipped - 74 lines] > > > > > > regards, francis 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 > You also need to change the Folder to the folder you are using. > [quoted text clipped - 76 lines] > > > > > > > > regards, francis 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 > Hi Joel > [quoted text clipped - 108 lines] > > > > > > > > > > regards, francis 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 > Try replaceing the copy statement with this code. This will not copy the > format. If you neeed formats I'll need to use pastespecial. [quoted text clipped - 118 lines] > > > > > > > > > > > > regards, francis 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 > Try replaceing the copy statement with this code. This will not copy the > format. If you neeed formats I'll need to use pastespecial. [quoted text clipped - 118 lines] > > > > > > > > > > > > regards, francis Sorry I lost a period in the code from Do While Range("C" & RowCount) <> "" to Do While .Range("C" & RowCount) <> "" > Hi Joel > [quoted text clipped - 129 lines] > > > > > > > > > > > > > > regards, francis 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") > Hi Joel > [quoted text clipped - 129 lines] > > > > > > > > > > > > > > regards, francis 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 > found one more error. don't know why excel didn't give me an error > [quoted text clipped - 137 lines] > > > > > > > > > > > > > > > > regards, francis 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) > Hi Joel > [quoted text clipped - 148 lines] > > > > > > > > > > > > > > > > > > regards, francis 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) > Hi Joel > [quoted text clipped - 148 lines] > > > > > > > > > > > > > > > > > > regards, francis 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) > Hi Joel > [quoted text clipped - 148 lines] > > > > > > > > > > > > > > > > > > regards, francis 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 > The sheet name isn't in the workbook. Add this message box to help find > problem [quoted text clipped - 155 lines] > > > > > > > > > > > > > > > > > > > > regards, francis 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 > Hi Joel > [quoted text clipped - 177 lines] > > > > > > > > > > > > > > > > > > > > > > regards, francis 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 > Hi Joel > [quoted text clipped - 177 lines] > > > > > > > > > > > > > > > > > > > > > > regards, francis 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 > Hi Joel > [quoted text clipped - 177 lines] > > > > > > > > > > > > > > > > > > > > > > regards, francis 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 > I keep on missing things. This has a few improvements and corrections > [quoted text clipped - 248 lines] > > > > > > > > > > > > > > > > > > > > > > > > regards, francis 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 > I did some more testing and found some minor errors. He is the code that > should work exactly the way you asked for it. [quoted text clipped - 263 lines] > > > > > > > > > > > > > > > > > > > > > > > change folder name as required 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 > Hi Joel > [quoted text clipped - 260 lines] > > > > > > > > > > > > > > > > > > > > > > > Hi Joel Thank you! Joel cheers, francis > This code will get unique items in column C and give a total. > [quoted text clipped - 261 lines] > > > > > > > > > > > > > > > > > > > > > Hi Joel |
Reply to this Message |
 Sign In
 Join
 My Latest Posts My Monitored Threads My Blog My Photo Gallery My Profile My Homepage Start New Thread Enable EMail Alerts Rate this Thread
|
©2008 Advenet LLC Privacy Policy - Terms of Use
This website includes both content owned or controlled by Advenet as well as content owned or controlled by third parties.