Option Compare Database
Function SearchForString(sFile As String)
' Excel object variables
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
' Access object variables
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim strPOLine As String
Dim strRowValue As String
Dim strIdentifyRow As String
Dim intPOLinePO As Integer
Dim iResponse As Integer
On Error GoTo Err_Execute
' Create the Excel Application, Workbook and Worksheet and Database object
Set appExcel = GetObject(, "Excel.Application")
Set wbk = appExcel.Workbooks.Open(sFile)
' Load current worksheet. Find used range to determine row count.
Set wks = appExcel.Worksheets(1)
Call DelRows(sFile, wks, appExcel)
'Start search in row 1
LSearchRow = 1
'Start copying data to column 2 in shhet 1 (row counter variable)
LCopyToRow = 1
While Len(appExcel.Range("A" & CStr(LSearchRow)).Value) > 0
strRowValue = (appExcel.Range("A" & CStr(LSearchRow)).Value)
strIdentifyRow = Left(Trim(strRowValue), 10)
If InStr(1, strIdentifyRow, "45") = 1 Then
'If value in column A = criteria, copy key value to column 2
strPOLinePO = Trim(Left(Trim(Mid(strRowValue, (InStr(strRowValue, " ")), (Len(strRowValue)))), 8))
strPOLine = strPOLinePO
ElseIf InStr(1, strIdentifyRow, "/") = 3 Then
strPOLine = strPOLinePO
Else
GoTo SkipRow
End If
appExcel.Range("B" & CStr(LSearchRow)).Select
ActiveCell.Value = strPOLine
SkipRow:
LSearchRow = LSearchRow + 1
LCopyToRow = LCopyToRow + 1
Wend
appExcel.Application.DisplayAlerts = False
wbk.Close SaveChanges:=True
appExcel.Application.DisplayAlerts = True
Set wks = Nothing
Set wbk = Nothing
Set appExcel = Nothing
Call ExcelImport(sFile)
Call ImportCheck(iResponse, sFile)
Select Case iResponse
Case 0
Call SplitImport
Case 1
Call SplitImport
Case 2
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "Sheet1"
DoCmd.SetWarnings True
End Select
Exit Function
Err_Execute:
Select Case Err.Number
Case 429
'Excel is not running; open Excel with CreateObject
Set appExcel = CreateObject("Excel.Application")
Resume Next
Case Else
MsgBox Err.Number & ": " & Err.Description
Exit Function
End Select
End Function
Function DelRows(sFile As String, wks As Excel.Worksheet, appExcel As Excel.Application)
' Access object variables
Dim DMyRow As Range
Dim DLSearchRow As Integer
DLSearchRow = 1
For Each DMyRow In ActiveSheet.UsedRange.Rows
If Len(appExcel.Range("A" & CStr(DLSearchRow)).Value) = 0 Then
appExcel.Range("A" & CStr(DLSearchRow)).EntireRow.Delete
End If
DLSearchRow = DLSearchRow + 1
Next DMyRow
End Function
Function ExcelImport(sFile As String)
On Error GoTo Err_Execute
'DoCmd.RunSQL "DROP TABLE Sheet1;"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"Sheet1", sFile, False
'MsgBox "File imported, ready to split."
DoCmd.RunSQL "ALTER TABLE Sheet1 ADD COLUMN ID COUNTER(1,1) CONSTRAINT PrimaryKey PRIMARY KEY;"
Exit Function
Err_Execute:
Select Case Err.Number
Case 3376
Resume Next
Case Else
MsgBox Err.Number & ": " & Err.Description
Exit Function
End Select
End Function
Function SplitImport()
On Error GoTo ErrHandler
Dim db As DAO.Database
Dim rsS As DAO.Recordset
Dim strSQL As String
Dim lngReportID As Long
Dim qdfSQL As QueryDef
Dim sngTime As Single
Set db = CurrentDb()
Set qdfSQL = db.QueryDefs("AppQ_Imported")
qdfSQL.Execute
DoCmd.SetWarnings False
Set qdfSQL = db.QueryDefs("AppQ_Report")
qdfSQL.Execute
strSQL = "SELECT Max(Tbl_Report.ReportID) AS MaxOfReportID FROM Tbl_Report;"
Set rsS = db.OpenRecordset(strSQL, dbOpenDynaset)
lngReportID = rsS!MaxOfReportID
strSQL = "INSERT INTO Tbl_PO_Line_Temp ( PONum, CustEmpID, Name, ReportID )" & _
"SELECT SelQ_PO_Line_1.PONum, SelQ_PO_Line_1.CustEmpID, " & _
"SelQ_PO_Line_1.Name, " & lngReportID & " FROM SelQ_PO_Line_1;"
DoCmd.RunSQL strSQL
DoCmd.OpenQuery "AppQ_PO_Line_Final"
DoCmd.OpenQuery "DelQ_PO_Line_Temp"
DoCmd.OpenQuery "AppQ_PO_SubLine_Temp_1"
DoCmd.OpenQuery "AppQ_PO_SubLine_Temp_2"
DoCmd.OpenQuery "AppQ_PO_SubLine_Final"
DoCmd.OpenQuery "DelQ_PO_SubLine_Temp_1"
DoCmd.OpenQuery "DelQ_PO_SubLine_Temp_2"
DoCmd.OpenQuery "AppQ_Imported"
DoCmd.DeleteObject acTable, "Sheet1"
DoCmd.SetWarnings True
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
End Function
Function ImportCheck(iResponse As Integer, sFile As String)
On Error Resume Next
Dim strSearch As String
Dim strSQL As String
Dim rsI As DAO.Recordset
Dim rsC As DAO.Recordset
Dim lngLoc As Long
Dim lngRow As Long
Dim lngI As Long
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
iResponse = 0
Set rsI = CurrentDb.OpenRecordset("SelQ_DateTime")
strSearch = rsI!DateTime
Set rsC = CurrentDb.OpenRecordset("Tbl_Imported")
If Not rsC.BOF Then
lngRow = 1
Do Until rsC.EOF
For lngI = 0 To rsC.Fields.Count - 1
lngLoc = InStr(1, rsC.Fields(lngI).Value, strSearch)
If lngLoc <> 0 Then
Msg = "This report, '" & sFile & "' has already been imported! Do you want to import it again?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Warning! Importing again may cause duplicate records!" ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
iResponse = 1
GoTo GoingAnyway
Else ' User chose No.
iResponse = 2
GoTo GoingAnyway
End If
End If
lngLoc = 0
Next lngI
lngRow = lngRow + 1
rsC.MoveNext
Loop
End If
GoingAnyway:
rsC.Close
rsI.Close
Set rsC = Nothing
Set rsI = Nothing
End Function