Merge multiple Excel spreahsheets into single one
This tip describes how to mrge multiple Excel spreahsheets into single one.
I had to write this script for a financial system. It was a major requirement and saved them atleast 2-3 hours everyday. This system stores the details of a broker. Each broker deals with different products and have different terms and condition excel embedded file. Application user wanted a script to merge all the data from embedded excel files into single excel file for a single product. The script below is a view action script, it processes all the documents in current view, it gets handle to embedded excel object copies the data from it into a new merged excel file. It also names the worksheets with proper broker name in the merged excel file.



Download: IT Certifications 101
Inside this exclusive essential guide, our independent experts break down which IT certifications are worth your time and effort, and how to get started obtaining them to further your career— including specific certifications that any cloud or desktop pro should seriously consider.
By submitting your personal information, you agree that TechTarget and its partners may contact you regarding relevant content, products and special offers.
You also agree that your personal information may be transferred and processed in the United States, and that you have read and agree to the Terms of Use and the Privacy Policy.
This code can be put into a agent and called from any view.
'On Error Goto ErrorHandler Dim s As New notessession Dim ws As New notesuiworkspace Dim db As notesdatabase Dim doc As notesdocument Dim dcol As notesdocumentcollection Dim UIview As NotesUIView Dim view As notesview Set db=s.currentdatabase 'Set dcol=db.unprocesseddocuments Set UIview = ws.CurrentView Set view = UIview.view Set doc = view.getlastdocument 'GEt the profile document where all the values are saved Set pdoc = db.getprofiledocument("PaymentExcelKeywords") DirectoryToSave = "C:Temp" & doc.Product(0)& ".xls" 'Trim$(pitm.values(0)) WorkbookName = doc.Product(0)& ".xls" Dim handle As Variant Dim ws1 As Variant Dim o1 As notesembeddedobject Dim idisp As Variant Dim prevBrokerName() As String Dim counter As Integer Redim Preserve prevBrokerName(counter) 'Launch Excel and open it in the UI On Error 208 Goto createNew Set excelAppObject = GetObject ( "" , "Excel.Application") If excelAppObject Is Nothing Then createNew: Print " Error " & Cstr(Err) & " " & Error(Err) & " Line " & Cstr(Erl) Set excelAppObject = CreateObject("Excel.Application") End If On Error Goto ErrorHandler excelAppObject.Visible = True excelAppObject.Workbooks.Add 'Save the newly created workbook, so that we can name it to refer to it in future Set excelWorksheetObject = excelAppObject.ActiveSheet If Not Dir$(DirectoryToSave)="" Then Kill DirectoryToSave End If excelWorksheetObject.saveas DirectoryToSave While Not doc Is Nothing If Not doc Is Nothing Then If doc.hasembedded=False Then 'excelAppObject.Windows("Book1").Activate excelAppObject.Windows(WorkbookName).Activate Set excelWorksheetObject = excelAppObject.ActiveSheet excelWorksheetObject.Select temp = doc.BrokerName(0) If Len(temp)>30 Then temp = Left$(temp, 30) excelWorksheetObject.Name=temp Else Set ws1 = doc.getfirstitem("Rates") If Not (ws1 Is Nothing) Then Set o1 = ws1.getembeddedobject("Microsoft Excel Worksheet") If Not (o1 Is Nothing) Then Set idisp = o1.activate(True) Set excelWorksheetObject = idisp.ActiveSheet 'idisp.ActiveSheet.copy excelAppObject.Workbooks("Book1").Sheets(1) idisp.ActiveSheet.copy excelAppObject.Workbooks(WorkbookName).Sheets(1) 'Paste the copied cells from the embedded excel object to 'newly created worksheet Set excelWorksheetObject = excelAppObject.ActiveSheet excelWorksheetObject.Select 'Broker names with "()" in them generate errors when 'assiging them to worksheet hence replace these with 'other characters. temp = doc.BrokerName(0) If Len(temp)>31 Then temp = Left$(temp, 31) 'check if the name is not given previously NotFound=0 If prevBrokerName(0) <> "" Then For i=0 To Ubound(prevBrokerName) If Lcase(temp) = Lcase(prevBrokerName(i)) Then NotFound=1 Exit For End If Next End If If NotFound = 1 Then temp = Left(temp, 30) & Right(doc.noteid,1) excelWorksheetObject.Name=temp Else excelWorksheetObject.Name=temp End If excelWorksheetObject.Range("A1").Select End If 'Try deleting the objects Delete o1 End If End If End If Redim Preserve prevBrokerName(counter) prevBrokerName(counter) = temp Set doc = view.getprevdocument(doc) counter = counter + 1 Wend 'Check before trying to save if there is file already 'If yes then delete the file and then create a new one. excelWorksheetObject.Range("A1").Select 'excelAppObject.Windows("Book1").Activate excelAppObject.Windows(WorkbookName).Activate 'If Not Dir$(DirectoryToSave)="" Then ' Kill DirectoryToSave 'End If 'excelWorksheetObject.saveas DirectoryToSave excelAppObject.Workbooks(1).Close True 'Now attach the generated file to the mail file and send it Dim maildoc As New notesdocument(db) Dim rtitem As NotesRichTextItem Dim mailAddr() As String Set pitm = pdoc.getfirstitem("SingleTandCFileSendToAddress") If Not pitm Is Nothing Then For i=0 To Ubound(pitm.values) Redim Preserve mailAddr(i) mailAddr(i) = pitm.values(i) Next maildoc.SendTo = mailaddr Else Error(3333) End If maildoc.subject = "Merged Terms & Conditions file for single product" Set rtitem = New NotesRichTextItem( maildoc, "Body" ) Set object = rtitem.EmbedObject( EMBED_ATTACHMENT, "", DirectoryToSave) maildoc.Form="Memo" Call ws.editdocument(True, maildoc) 'maildoc.Send(False) 'Delete the file from the users harddisk Kill DirectoryToSave excelAppObject.quit Msgbox "Merging of T&C file complete!", 64, "Merging Function Dialog" EndSub: Exit Sub ErrorHandler: Print " Error " & Cstr(Err) & " " & Error(Err) & " Line " & Cstr(Erl) 'Msgbox strError Resume EndSub End Sub
Start the conversation
0 comments