Append two excel files to ms access table using VBA

[mahhogany]

This code works perfectly to append one excel file but I need help to amend it so it can append one file after another. Any ideas?

Option Compare Database
Option Explicit

Const constColumns = 53
Const constFirstLine = 17

' Tracker Fields
Const constRef = 1
Const constDate_of_Reg = constRef + 1
Const constCompany = constRef + 2
Const constContractor = constRef + 3
Const constDirectorate = constRef + 4
Const constProgram_Project = constRef + 5
Const constContract_Descr = constRef + 6
Const constSupply_Service_or_Works = constRef + 7
Const constForm_of_Contract = constRef + 8
Const constTotal_Value = constForm_of_Contract + 1
Const constContract_and_variation_no = constForm_of_Contract + 3
Const constAgreed_Award_Date = constTotal_Value + 4
Const constPeriod_of_Award_Date = constTotal_Value + 5
Const constCustomer_GM = constAgreed_Award_Date + 5
Const constCustomer_BM = constCustomer_GM + 1
Const constGM_Area = constCustomer_BM + 1
Const constGM = constCustomer_BM + 3
Const constBM = constCustomer_BM + 4
Const constProc_Contact = constCustomer_BM + 5
Const constLegal_Contact = constCustomer_BM + 6
Const constCurrent_Status = constLegal_Contact + 1
Const constReason_Code = constLegal_Contact + 3
Const constNext_Management_Steps = constLegal_Contact + 4
Const constActual_Contract_date = constNext_Management_Steps + 11
Const constPeriod_Contract_date = constNext_Management_Steps + 12
Const constStatus = constNext_Management_Steps + 14

Dim appExcel As Excel.Application
Dim xlBook As Object
Dim xlSheet As Object

Dim db As Database
Dim rs As Recordset

Public Sub basControl_Import()

' controlling subroutine for import Excel information
If basOpenRecordset() Then
If basOpenExcel _
("Z:\\ Procurement\\Performance\Contracts.xls") _
Then
End If
End If

End Sub

Public Function basOpenRecordset() As Boolean

On Error GoTo basOpenRecordset_err

' Empty the table used to hold the imported information
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * FROM tblLive_Tracker"
DoCmd.SetWarnings True

' open the table in preperation of importing the data
Set db = DBEngine(0)(0)
Set rs = db.OpenRecordset("tblLive_Tracker", DB_OPEN_DYNASET)

basOpenRecordset_ok:
On Error Resume Next
basOpenRecordset = True
Exit Function

basOpenRecordset_err:
MsgBox "Error clearing and then opening tblLive Tracker : " & Error(Err)
basOpenRecordset = False
Resume basOpenRecordset_ok


End Function

Public Function basOpenExcel(strFile As String) As Boolean


Dim intI As Integer
Dim intJ As Integer

'Debug.Print "Start: " & Now()
' open Excel as an object
On Error GoTo basOpenExcel_err
Set appExcel = CreateObject("Excel.Application")

' Open the workbook
Set xlBook = appExcel.Workbooks.Open(strFile)
'Open the first worksheet
Set xlSheet = xlBook.Sheets("TRACKER")

' Set the start point
intI = constFirstLine

' Keep reading lines until the first cell on a line contains an empty string
While Len(xlSheet.Cells(intI, 1)) <> 0
'Debug.Print intI
' Check to see if this line is a recognised data line
If basDataline(intI) Then
' Pull in the fields and add to the recordset
basAddLine (intI)
End If
' Next row
intI = intI + 1
Wend

basOpenExcel = True

basOpenExcel_ok:
' Exit routine
On Error Resume Next
' Close the workbook (no changes to save)
xlBook.Close SaveChanges:=False
' Quit Excel
appExcel.Quit
'Debug.Print "Stop: " & Now()
Exit Function

basOpenExcel_err:
' Error handling
MsgBox "Error opening Excel workbook " & strFile & " worksheet Master Tracker : " & Error(Err)
basOpenExcel = False
Resume basOpenExcel_ok


End Function

Public Function basDataline(intRow As Integer) As Boolean

' Specific test to see if this row has data that we want to import
If xlSheet.Cells(intRow, 1) <> "Overall Result" Then
basDataline = True
Else
basDataline = False
End If

End Function

Public Sub basAddLine(intLine As Integer)
'Dim tmpDate_12Months As Date
'Dim tmpDate_09Months As Date

DoCmd.SetWarnings True
On Error GoTo basAddline_err

' Create a row in the recordset
rs.AddNew
' Update the fields with the specific data, each field is a specific type)
rs![Ref] = basGetTextField(intLine, constRef)
rs![Date_of_Reg] = basGetDateField(intLine, constDate_of_Reg)
rs![Contractor] = basGetTextField(intLine, constContractor)
rs![Company] = basGetTextField(intLine, constCompany)
rs![Directorate] = basGetTextField(intLine, constDirectorate)
rs![Program_Project] = basGetTextField(intLine, constProgram_Project)
rs![Contract_Descr] = basGetTextField(intLine, constContract_Descr)
rs![Supply_Service_or_Works] = basGetTextField(intLine, constSupply_Service_or_Works)
rs![Form_of_Contract] = basGetTextField(intLine, constForm_of_Contract)
rs![Total_Value] = basGetNumericField(intLine, constTotal_Value)
rs![Agreed_Award_Date] = basGetDateField(intLine, constAgreed_Award_Date)
rs![Period_of_Agreed_date] = basGetTextField(intLine, constPeriod_of_Award_Date)
rs![Customer_GM] = basGetTextField(intLine, constCustomer_GM)
rs![Customer_BM] = basGetTextField(intLine, constCustomer_BM)
rs![Proc_GM] = basGetTextField(intLine, constGM)
rs![Proc_BM] = basGetTextField(intLine, constBM)
rs![Proc_Contact] = basGetTextField(intLine, constProc_Contact)
rs![Legal_Contact] = basGetTextField(intLine, constLegal_Contact)
rs![Current_Status] = basGetTextField(intLine, constCurrent_Status)
rs![Reason_Code] = basGetTextField(intLine, constReason_Code)
rs![Next_Managment_Steps] = basGetTextField(intLine, constNext_Management_Steps)
rs![Actual_Contract_date] = basGetDateField(intLine, constActual_Contract_date)
rs![Period_contract_date] = basGetTextField(intLine, constPeriod_Contract_date)
rs![Status] = basGetTextField(intLine, constStatus)
rs![Contract_and_variation_no] = basGetTextField(intLine, constContract_and_variation_no)
rs![Proc_Area] = basGetTextField(intLine, constGM_Area)


'tmpDate_12Months = DateAdd("m", -12, Date)
'tmpDate_09Months = DateAdd("m", -9, Date)
'rs![agencyLengthOfService] = IIf(rs![agencyDES] < tmpDate_12Months, 12, IIf(rs!agencyDES < tmpDate_09Months, 9, 0))

rs.Update

DoCmd.SetWarnings False

basAddLine_ok:
Exit Sub

basAddline_err:
MsgBox "Error appending line to tblLive Tracker line [" & intLine & "] : " & Error(Err)
Resume basAddLine_ok

End Sub


Public Function basGetTextField(intLine, intCol) As String

' Text field
On Error GoTo basGetTextField_err

basGetTextField = xlSheet.Cells(intLine, intCol)

basGetTextField_ok:
On Error Resume Next
Exit Function

basGetTextField_err:

MsgBox "Error importing text from row " & intLine & " column " & intCol & " " & xlSheet.Cells(intLine, intCol)
basGetTextField = ""
Resume basGetTextField_ok

End Function

Public Function basGetNumericField(intLine, intCol) As Long

' Numeric field
On Error GoTo basGetNumericField_err

basGetNumericField = xlSheet.Cells(intLine, intCol)

basGetNumericField_ok:
On Error Resume Next
Exit Function

basGetNumericField_err:
MsgBox "Error importing numeric from row " & intLine & " column " & intCol & " " & xlSheet.Cells(intLine, intCol)
basGetNumericField = 0
Resume basGetNumericField_ok

End Function

Public Function basGetDateField(intLine, intCol) As Date
' Date field
On Error GoTo basGetdateField_err

basGetDateField = xlSheet.Cells(intLine, intCol)

basGetdateField_ok:
On Error Resume Next
Exit Function

basGetdateField_err:
'MsgBox "Error importing date from row " & intLine & " column " & intCol & " " & xlSheet.Cells(intLine, intCol)
basGetDateField = #1/1/1900#
Resume basGetdateField_ok

End Function

 

[DCrake]

Q1:Is there any differences between the workbooks? layout not data.
Q2:How arer you calling the code now?
Q3:How is the variable strFile being populated? - Name of workbook file

 

[mahhogany]

The second workbook is of the same layout but there may be a third one with a different layout later. However I would like to get this one sorted for now.

The second file is in the same directory but called Contracts Maint.xls

I don't understand Q2.

 

[DCrake]

At some point in the application you must be invoking the code you have provided. This my be by way of clicking a button on a form. Invoking a macro, some other method. What I woulod like to know is what other piece of code is calling this code. It may be something like this

x = basOpenExcel("Contracts Maint.xls")

Do a search in you code for "Contracts Maint.xls"

 

[mahhogany]

ok I understand. I haven't added the second file yet. That is where I am stuck. At the moment the code above is calling the first file only.

Public Sub basControl_Import()

' controlling subroutine for import Excel information
If basOpenRecordset() Then
If basOpenExcel _
("Z:\\ Procurement\\Performance\Contracts.xls") _
Then
End If
End If

End Sub

I tried to use a Do while Loop to include the second file but it completely fell over. The code is below

Public Sub basControl_Import()

' controlling subroutine for import Excel information
Do While Not rs
If basOpenRecordset() Then
If basOpenExcel _
("Z:\\ Procurement\\Performance\Contracts.xls") _
Then
End If
' Rest of your code here.
If basOpenRecordset() Then
If basOpenExcel _
("Z:\\ Procurement\\Performance\\Contracts Maint.xls") _
Then
End If
Loop
End Sub

Ideally I would like some ideas on how to make the append the first file and then loop back to do the other.

 

[DCrake]

You do not need the Do While Loop just call the code twice but with different xls file names. However are both sets of spreadsheet going into the tblLive_Tracker table? I don't think so becuase one of the first steps is does is to delete the contents of this table. You may need to rebuild the coding structure to get this to work efficiently.

 

[mahhogany]

You do not need the Do While Loop just call the code twice but with different xls file names. However are both sets of spreadsheet going into the tblLive_Tracker table? I don't think so becuase one of the first steps is does is to delete the contents of this table. You may need to rebuild the coding structure to get this to work efficiently.

You are correct. Both sets of data should go to the Live Tracker table and the contents of that table should be deleted before I can append the data from the two tables to it.

Do you have any tips on how to do this?

 

[DCrake]

Firt thing you need to do is to remove the following out of the sub routine

' Empty the table used to hold the imported information
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * FROM tblLive_Tracker"
DoCmd.SetWarnings True

Place this outside the code but run prior to invoking the import Sub

Public Sub basControl_Import()

' controlling subroutine for import Excel information
If basOpenRecordset() Then
  x = basOpenExcel  ("Z:\\ Procurement\\Performance\Contracts1.xls")
   DoEvents
  x = basOpenExcel  ("Z:\\ Procurement\\Performance\Contracts2.xls")

End If

End Sub