Sunday, 6 March 2011

Excel Import

Sub Initialize Dim session As New NotesSession Dim db As NotesDatabase Dim doc As NotesDocument Dim xlApp As Variant, xlsheet As Variant, xlwb As Variant, xlrange As Variant Dim filename As String, currentvalue As String Dim batchRows As Integer, batchColumns As Integer, totalColumns As Integer Dim x As Integer, y As Integer, startrow As Integer Dim curRow As Long, timer1 As Long, timer2 As Long Dim DataArray, fieldNames, hasData timer1=Timer filename="C:\temp\RISEImport.xls" batchRows=200 'process 200 rows at a time Set db=session.CurrentDatabase Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True 'set Excel program to run in foreground to see what is happening Set xlwb=xlApp.Workbooks.Open(filename) Set xlsheet =xlwb.Worksheets(1) Redim fieldNames(1 To 250) As String DataArray=xlsheet.Range("A1").Resize(batchRows, 250).Value 'get worksheet area of specified size For y=1 To 250 'we assume max 250 columns in the sheet currentvalue=Cstr(DataArray(1,y)) If currentvalue<>"" Then 'abort counting on empty column fieldNames(y)=currentvalue 'collect field names from the first row totalColumns=y Else y=250 End If Next Redim Preserve fieldNames(1 To totalColumns) As String curRow=2 hasData=True While hasData=True 'loop until we get to the end of Excel rows If curRow=2 Then startrow=2 Else startrow=1 For x=startrow To batchRows curRow=curRow+1 If Cstr(DataArray(x,1))+Cstr(DataArray(x,2))<>"" Then 'when 2 first columns are empty, we assume that it's the end of data Print Cstr(curRow-2) Set doc=New NotesDocument(db) doc.Form="FProc" For y=1 To totalColumns currentvalue=Cstr(DataArray(x,y)) Call doc.ReplaceItemValue(fieldNames(y), currentvalue) Next Call, False) Else hasData=False x=batchRows End If Next If hasData=True Then DataArray=xlsheet.Range("A"+Cstr(curRow)).Resize(batchRows, totalColumns).Value 'get worksheet area Wend timer2=Timer Call xlApp.Quit() 'close Excel program Msgbox "Done in "+Cstr(timer2-timer1)+" seconds" End Sub

No comments:

Post a Comment