Merge multiple Excel spreahsheets into single one

• Amit Kamat
• Published: 17 Oct 2002

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