Merge 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.

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
  Print " Error " & Cstr(Err) & " " & Error(Err) & " Line " & Cstr(Erl)
  Set excelAppObject = CreateObject("Excel.Application")
 End If
 On Error Goto ErrorHandler
 excelAppObject.Visible = True
 '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 
    Set excelWorksheetObject = excelAppObject.ActiveSheet
    temp = doc.BrokerName(0)
    If Len(temp)>30 Then temp = Left$(temp, 30)
    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
      '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
      If prevBrokerName(0) <> "" Then
       For i=0 To Ubound(prevBrokerName)
        If Lcase(temp) = Lcase(prevBrokerName(i)) Then 
         Exit For
        End If
      End If
      If NotFound = 1 Then
       temp = Left(temp, 30) & Right(doc.noteid,1)
      End If
     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
 'Check before trying to save if there is file already
 'If yes then delete the file and then create a new one.
 '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)
  maildoc.SendTo = mailaddr
 End If
 maildoc.subject = "Merged Terms & Conditions file for single product"
 Set rtitem = New NotesRichTextItem( maildoc, "Body" )
 Set object = rtitem.EmbedObject( EMBED_ATTACHMENT, "", DirectoryToSave)
 Call ws.editdocument(True, maildoc)
 'Delete the file from the users harddisk
 Kill DirectoryToSave
 Msgbox "Merging of T&C file complete!", 64, "Merging Function Dialog"
 Exit Sub
 Print " Error " & Cstr(Err) & " " & Error(Err) & " Line " & Cstr(Erl)
 'Msgbox strError
 Resume EndSub
End Sub

This was first published in October 2002

There are Comments. Add yours.

TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

Disclaimer: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.