Sub MakeTableQBTransactions()
On Error GoTo MakeTableQBTransactions_err
Screen.MousePointer = 11
Dim Response, s As String
s = "Continuing will create a new table of vehicle " & Chr(10) & _
"transactions from the QuickBooks file currently open." & Chr(10) & Chr(10) & _
"This will not affect transactions in the database " & Chr(10) & _
"that were imported from other QuickBooks files." & Chr(10) & Chr(10) & _
"Depending on the number of transactions in the open" & Chr(10) & _
"QuickBooks file, this may take several minutes." & Chr(10) & Chr(10) & _
"Do you wish to continue?"
Response = MsgBox(s, vbCritical + vbYesNo, "Continue?")
If Response = vbNo Then Exit Sub
Dim dtFrom As Date, sFrom As String, dtTo As Date, sTo As String
dtFrom = InputBox("Enter the beginning date you wish to import:", "Beginning Date", "##/##/##")
dtTo = InputBox("Enter the ending date you wish to import:", "Ending Date", "##/##/##")
sFrom = "{d '" & Year(dtFrom) & "-" & Right("00" & Month(dtFrom), 2) & "-" & Right("00" & Day(dtFrom), 2) & "'}"
sTo = "{d '" & Year(dtTo) & "-" & Right("00" & Month(dtTo), 2) & "-" & Right("00" & Day(dtTo), 2) & "'}"
Dim db As DAO.Database, qd As DAO.QueryDef, t As String, q As String, QBCompany
QBCompany = fncQBCompany
q = "tempQuery"
t = "tblQBTrans_" & QBCompany & " " & _
Year(dtFrom) & Right("00" & Month(dtFrom), 2) & Right("00" & Day(dtFrom), 2) & " to " & _
Year(dtTo) & Right("00" & Month(dtTo), 2) & Right("00" & Day(dtTo), 2)
Set db = CurrentDb
Set qd = db.CreateQueryDef(q)
qd.ReturnsRecords = True
qd.Connect = "ODBC;DSN=QuickBooks Data;SERVER=QODBC"
qd.ODBCTimeout = 60
s = "sp_report CustomTxnDetail show TxnType, Date, RefNumber," & _
" Name, SourceName, Memo, Account, ClearedStatus, SplitAccount, Debit, Credit " & _
" parameters datefrom =" & sFrom & " , dateto=" & sTo & "," & _
" SummarizeRowsBy = 'TotalOnly' "
qd.SQL = s
DoCmd.SetWarnings False
DoCmd.RunSQL "select * into [" & t & "] from [" & q & "]"
Set qd = Nothing
Set qd = db.CreateQueryDef(q)
s = ""
Dim x As Integer
For x = 0 To db.TableDefs.Count - 1
If InStr(1, db.TableDefs(x).Name, "tblQBTrans_", vbTextCompare) > 0 Then
s = s & "select * from [" & db.TableDefs(x).Name & "] union "
End If
Next x
s = Left(s, (Len(s)) - 7) & " order by date;"
qd.SQL = s
DoCmd.RunSQL "select * into [Transactions " & QBCompany & "] from [" & q & "] where txntype is not null"
Set qd = Nothing
Set db = Nothing
DoCmd.OpenTable "Transactions " & QBCompany
Screen.MousePointer = 0
Exit Sub
MakeTableQBTransactions_err:
If Err.Number = 3012 Then
DoCmd.DeleteObject acQuery, q
Resume
End If
Debug.Print Erl & ": " & Err.Number & " " & Err.Description
End Sub
Function fncQBCompany()
On Error GoTo fncQBCompany_err
Dim db As DAO.Database, qd As DAO.QueryDef, rs As DAO.Recordset, q As String, t As String
q = "qCompanyName"
t = "tblCompanyName"
Set db = CurrentDb
Set qd = db.CreateQueryDef(q)
qd.Connect = "ODBC;DSN=QuickBooks Data;SERVER=QODBC"
qd.ReturnsRecords = True
qd.ODBCTimeout = 60
qd.SQL = "select companyname from company"
DoCmd.SetWarnings False
DoCmd.RunSQL "select * into " & t & " from " & q
Set rs = db.OpenRecordset(t)
rs.MoveLast
rs.MoveFirst
fncQBCompany = rs!companyname
fncQBCompany = Replace(Replace(fncQBCompany, ",", ""), ".", "")
rs.Close
Set rs = Nothing
Set qd = Nothing
Set db = Nothing
Exit Function
fncQBCompany_err:
If Err.Number = 3012 Then
DoCmd.DeleteObject acQuery, q
Resume
End If
Debug.Print Erl & ": " & Err.Number & " " & Err.Description
End Function
Sub ImportTransactions(dtFrom As Date, dtTo As Date, frm As Form)
On Error GoTo ImportTransactions_err
Screen.MousePointer = 11
frm.RecordSource = ""
Dim Response, s As String
s = "Continuing will create a new table of vehicle " & Chr(10) & _
"transactions from the QuickBooks file currently open." & Chr(10) & Chr(10) & _
"This will not affect transactions in the database " & Chr(10) & _
"that were imported from other QuickBooks files." & Chr(10) & Chr(10) & _
"Depending on the number of transactions in the open" & Chr(10) & _
"QuickBooks file, this may take several minutes." & Chr(10) & Chr(10) & _
"Do you wish to continue?"
Response = MsgBox(s, vbCritical + vbYesNo, "Continue?")
If Response = vbNo Then Exit Sub
Dim sFrom As String, sTo As String
sFrom = "{d '" & Year(dtFrom) & "-" & Right("00" & Month(dtFrom), 2) & "-" & Right("00" & Day(dtFrom), 2) & "'}"
sTo = "{d '" & Year(dtTo) & "-" & Right("00" & Month(dtTo), 2) & "-" & Right("00" & Day(dtTo), 2) & "'}"
Dim db As DAO.Database, qd As DAO.QueryDef, t As String, q As String, QBCompany
QBCompany = fncQBCompany
q = "tempQuery"
t = "tblQBTrans_" & QBCompany & " " & _
Year(dtFrom) & Right("00" & Month(dtFrom), 2) & Right("00" & Day(dtFrom), 2) & " to " & _
Year(dtTo) & Right("00" & Month(dtTo), 2) & Right("00" & Day(dtTo), 2)
Set db = CurrentDb
Set qd = db.CreateQueryDef(q)
qd.ReturnsRecords = True
qd.Connect = "ODBC;DSN=QuickBooks Data;SERVER=QODBC"
qd.ODBCTimeout = 60
s = "sp_report CustomTxnDetail show TxnType, Date, RefNumber," & _
" Name, SourceName, Memo, Account, ClearedStatus, SplitAccount, Debit, Credit " & _
" parameters datefrom =" & sFrom & " , dateto=" & sTo & "," & _
" SummarizeRowsBy = 'TotalOnly'"
qd.SQL = s
DoCmd.SetWarnings False
DoCmd.RunSQL "select * into [" & t & "] from [" & q & "]"
Set qd = Nothing
Set qd = db.CreateQueryDef(q)
s = ""
Dim x As Integer
For x = 0 To db.TableDefs.Count - 1
If InStr(1, db.TableDefs(x).Name, "tblQBTrans_", vbTextCompare) > 0 Then
s = s & "select * from [" & db.TableDefs(x).Name & "] union "
End If
Next x
s = Left(s, (Len(s)) - 7) & " order by date;"
qd.SQL = s
DoCmd.RunSQL "select * into [Transactions " & QBCompany & "] from [" & q & "] where txntype is not null"
Set qd = Nothing
Set db = Nothing
Screen.MousePointer = 0
frm.RecordSource = QBCompany
Exit Sub
ImportTransactions_err:
If Err.Number = 3012 Then
DoCmd.DeleteObject acQuery, q
Resume
End If
Debug.Print Erl & ": " & Err.Number & " " & Err.Description
End Sub
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (1)
Commented:
"Yes" vote above.