Related
I have a report that uses the following SQL query:
SELECT AccountPerformanceAllHistory.AccountNumber,
AccountMaster.AccountName AS Name, AccountCurrentModel.Model,
AccountPerformanceAllHistory.MarketValue,
AccountPerformanceAllHistory.Cash, ModelDetailAllHistory.Risk,
AccountPerformanceAllHistory.QTD, AccountPerformanceAllHistory.YTD,
AccountPerformanceAllHistory.[1Yr], AccountPerformanceAllHistory.[3Yr],
AccountMaster.AccountAdvisor AS Advisor,
AccountPerformanceAllHistory.PerformanceDate,
AccountPerformanceAllHistory.Ticker
FROM ModelDetailAllHistory INNER JOIN ((AccountMaster INNER JOIN
AccountPerformanceAllHistory ON AccountMaster.[AccountNumber] =
AccountPerformanceAllHistory.[AccountNumber]) INNER JOIN
AccountCurrentModel ON AccountMaster.[AccountNumber] = AccountCurrentModel.
[AccountNumber]) ON ModelDetailAllHistory.[ModelName] =
AccountCurrentModel.Model
GROUP BY AccountPerformanceAllHistory.AccountNumber,
AccountMaster.AccountName, AccountCurrentModel.Model,
AccountPerformanceAllHistory.MarketValue,
AccountPerformanceAllHistory.Cash, ModelDetailAllHistory.Risk,
AccountPerformanceAllHistory.QTD, AccountPerformanceAllHistory.YTD,
AccountPerformanceAllHistory.[1Yr], AccountPerformanceAllHistory.[3Yr],
AccountMaster.AccountAdvisor, AccountPerformanceAllHistory.PerformanceDate,
AccountPerformanceAllHistory.Ticker
ORDER BY ModelDetailAllHistory.Risk, AccountPerformanceAllHistory.[1Yr]
DESC;
The report is run from a button-click:
Private Sub Command3_Click()
Dim StrWhichMonth As String
Dim StrWhichClient As String
Dim CYear, CMonth As Variant
Dim StrSearch As String
StrWhichMonth = InputBox("Enter YYMM you want to report:")
CYear = "20" & Mid(StrWhichMonth, 1, 2)
CMonth = Mid(StrWhichMonth, 3, 2)
StrWhichMonth = DateSerial(CYear, CMonth + 1, 0)
StrWhichClient = InputBox("Enter Client name ('*' for all):")
StrSearch = "AccountPerformanceAllHistory.PerformanceDate = #" & StrWhichMonth _
& "# AND AccountPerformanceAllHistory.Ticker = " & Chr(34) & "1" & Chr(34) & "" _
& " AND AccountMaster.AccountName Like " & Chr(34) & StrWhichClient & Chr(34)
StrWhichMonth = "AccountPerformanceAllHistory.PerformanceDate = #" & StrWhichMonth _
& "# AND AccountPerformanceAllHistory.Ticker = " & Chr(34) & "1" & Chr(34) & ""
DoCmd.SetWarnings False
' DoCmd.OpenReport "RPTAccountPerformanceAllHistorySummary", acViewReport, , StrWhichMonth
DoCmd.OpenReport "RPTAccountPerformanceAllHistorySummary", acViewReport, , StrSearch
DoCmd.SetWarnings True
End Sub
As you might can tell, I added the search for AccountName in the button click code. The old code works fine.
The new code, with the StrSearch string does not work. When the query is run, it prompts for "AccountMaster.AccountName" after the two InputBox prompts. I know this means something is wrong with the StrSearch, but I don't know what is wrong. I've searched around the web, but could not find a solution.
Any help is appreciated.
TIA
The field list in your source query includes this one ...
AccountMaster.AccountName AS Name
Since you aliased the field, the query result set does not include a field named AccountMaster.AccountName, so Access assumes it must be a parameter and asks you to supply a value for it. Use the alias instead instead of the original field name.
Change this ...
& " AND AccountMaster.AccountName Like " & Chr(34) & StrWhichClient & Chr(34)
to this ...
& " AND [Name] Like " & Chr(34) & StrWhichClient & Chr(34)
I am pulling data from database into a recordset then converting to array and then writing to a CSV.
In the database all date values are stored as timestamps in this format.
2016-05-04 08:00:00.000000
But when I write to the CSV file the timestamp does not include the milliseconds.
Anyone know how to preserve the milliseconds?
Does the data in the recordset include the milliseconds?
On Error Resume Next
Dim sPassword
Dim sUserID
Dim sDefaultLib
Dim sSystem
Dim cs
Dim rc
Dim objIEDebugWindow
sDefaultLib = *library*
sUserID = *userid*
sPassword = *password*
sSystem = *system*
cs = *connectionString*
Set con = CreateObject("ADODB.Connection")
Set data = CreateObject("ADODB.Recordset")
con.Open cs, sUserID, sPassword
rc = con.State
If (rc = 1) Then
strQuery = "SELECT * FROM Library.Table FETCH FIRST 15 ROWS ONLY FOR READ ONLY WITH UR"
data.CursorLocation = adUseClient
data.Open strQuery, con
Set filsSysObj = CreateObject("Scripting.FileSystemObject")
Dim theYear
Dim theMonth
Dim theDay
Dim mDate
mDate = Date()
theYear = DatePart("yyyy", mDate)
theMonth = Right(String(2, "0") & DatePart("m", mDate), 2)
theDate = Right(String(2, "0") & DatePart("d", mDate), 2)
mDate = theYear & theMonth & theDate
Set csvFile = filsSysObj.OpenTextFile("C:\SampleFile_" & mDate & ".csv", 8, True)
columnCount = data.Fields.Count
Set i = 0
For Each field In data.Fields
i= i + 1
If (i <> columnCount) Then
csvFile.Write Chr(34) & field.Name & Chr(34) & ","
Else
csvFile.Write Chr(34) & field.Name & Chr(34)
End If
Next
csvFile.Write vbNewLine
End If
rowCount = data.RecordCount
row = 0
Dim row
Dim column
Dim resultsArray
Dim dateArray
resultsArray = data.GetRows
debug "hi"
i = 0
Do Until i>5
MsgBox(i)
i = i + 1
'debug "in"
'Dim value
'Dim dArray()
'debug "in"
'value = Chr(34) & CStr(data.Fields(17).Value) & Chr(34) & ","
'dArray = additem(dArray, value)
'data.MoveNext
'dateArray = dArray
Loop
debug "out"
For row = 0 To UBound(resultsArray, 2)
For column = 0 To UBound(resultsArray, 1)
If row = UBound(resultsArray, 2) And column = UBound(resultsArray, 1) Then
csvFile.Write Chr(34) & resultsArray(column, row) & Chr(34)
Else
If column = 0 Then
csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
ElseIf column = 19 Then
csvFile.Write Chr(34) & FormatDateTime(resultsArray(column, row),4) & Chr(34) & ","
ElseIf column = 18 Then
csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
'ElseIf column = 17 Then
'csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
Else
csvFile.Write Chr(34) & resultsArray(column, row) & Chr(34) & ","
End If
End If
Next
csvFile.Write vbNewLine
Next
csvFile.close
'----------------------Helper Functions are below-----------------------------
Sub Debug(myText)
'Dim objIEDebugWindow must be defined globally
'Call like this "Debug variableName"
'Uncomment the next line to turn off debugging
'Exit Sub
If Not IsObject(objIEDebugWindow) Then
Set objIEDebugWindow = CreateObject("InternetExplorer.Application")
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = "<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = objIEDebugWindow.Document.Body.InnerHTML & myText & "<br>" & vbCrLf
End Sub
Function formatDate(sDate)
Dim theYear
Dim theMonth
Dim theDay
Dim formattedDate
theYear = Year(sDate)
theMonth = Right(String(2,"0") & DatePart("m", sDate),2)
theDay = Right(String(2,"0") & DatePart("d", sDate),2)
formattedDate = theYear & "-" & theMonth & "-" & theDate
formatDate = formattedDate
End Function
The only field I am having issues with is field 17 of the recordset.
It is a timestamp datatype from a DB2 database.
The issue was the format is a timestamp in DB2 database. When i pull into a recordset it loses the milliseconds. My solution was to modify the query to add an extra row that pulls in only milliseconds and then later concatenate that back to the date. Please see below. Thanks for everyones help.
if(rc = 1) then
logFile.write FormatDateTime(Now(), 3) & ": Database connection successful" & vbNewLine
logFile.write FormatDateTime(Now(), 3) &": Default Library: " & sDefaultLib & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": Signed into server as: " & sUserID & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": System: " & sSystem & vbNewLine
strQuery = "SELECT ws_date, groupcd, userid, firstname, lastname, clientcd, unitcd, categorycd, category, activity, wrktype, subwrktype, step_begin, step_end, report_indicator, report_indicator, count, event_dattim, key_date, key_time, key_milsec, microsecond(event_dattim) FROM *Library.Name* FOR READ ONLY WITH UR"
data.CursorLocation = adUseClient
data.open strQuery, con
if data.EOF then
logFile.write FormatDateTime(Now(), 3) & ": The query returned no data"
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". There was no worksteps file created. ----------------" & vbNewLine
logFile.close
end if
columnCount = data.Fields.Count
columnCount = columnCount - 1
Set filsSysObj = CreateObject("Scripting.FileSystemObject")
Set csvFile = filsSysObj.OpenTextFile("C:\VBScript\Dailys\" & fname, 8, True)
set i = 0
for each field in data.Fields
i= i + 1
if i < columnCount then
csvFile.Write chr(34) & field.name & chr(34) & ","
elseif i = columnCount then
csvFile.Write chr(34) & field.name & chr(34)
else
exit for
end if
next
csvFile.Write vbNewLine
else
logFile.write FormatDateTime(Now(), 3) & ": Database connection was unsuccessful. Database Connection Return Code: " & rc
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". ----------------" & vbNewLine
logFile.close
csvfile.close
wscript.quit
end if
dim row
dim column
dim resultsArray
resultsArray = data.GetRows
dim arrayRows
arrayRows = ubound(resultsArray, 2)
if arrayRows <> 0 then
logFile.write FormatDateTime(Now(), 3) & ": " & (arrayRows + 1) & " rows were successfully read into the array for file " & fname & vbnewline
for row = 0 to UBound(resultsArray, 2)
for column = 0 to (UBound(resultsArray, 1) - 1)
if row = Ubound(resultsArray, 2) and column = (ubound(resultsArray, 1) - 1) then
csvFile.Write chr(34) & resultsArray(column, row) & chr(34)
else
if column = 0 then
csvFile.Write chr(34) & formatDate(resultsArray(column, row)) & chr(34) & ","
elseif column = 19 then
csvFile.Write chr(34) & FormatDateTime(resultsArray(column, row),4) & chr(34) & ","
elseif column = 18 then
csvFile.Write chr(34) & formatDate(resultsArray(column, row)) & chr(34) & ","
elseif column = 17 then
Dim fDate
fDate = formatDate(resultsArray(column, row)) & " " & FormatDateTime(resultsArray(column, row),4) & ":" & second(resultsArray(column,row)) & "." & resultsArray((ubound(resultsArray, 1)), row)
csvFile.Write chr(34) & fDate & chr(34) & ","
else
csvFile.Write chr(34) & resultsArray(column, row) & chr(34) & ","
end if
end if
next
csvFile.Write vbNewLine
next
logfile.write FormatDateTime(Now(), 3) & ": " & (row) & " rows have been written to " & fname &vbNewLine
else
logFile.write FormatDateTime(Now(), 3) & ": There was no data in the query results array for file " & fname & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". ----------------" & vbNewLine
logfile.close
csvfile.close
wscript.quit
end if
csvFile.close
logfile.write "---------------- DailyWorkstepReport.vbs script successfully ended at " & Now() & "----------------" & vbNewLine
logfile.close
wscript.quit
REM ----------------------Helper Functions are below-----------------------------
Sub Debug( myText )
'Dim objIEDebugWindow must be defined globally
'Call like this "Debug variableName"
'Uncomment the next line to turn off debugging
'Exit Sub
If Not IsObject( objIEDebugWindow ) Then
Set objIEDebugWindow = CreateObject( "InternetExplorer.Application" )
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = "<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = objIEDebugWindow.Document.Body.InnerHTML & myText & "<br>" & vbCrLf
End Sub
function formatDate(sDate)
Dim theYear
Dim theMonth
Dim theDay
Dim formattedDate
theYear = Year(sDate)
theMonth = Right(String(2,"0") & DatePart("m", sDate),2)
theDay = Right(String(2,"0") & DatePart("d", sDate),2)
formattedDate = theYear & "-" & theMonth & "-" & theDate
formatDate = formattedDate
end function
I am trying to import data from Excel into Access. Both 2010. Everything worked perfectly until I came across a cell that contained [text 'A' text]. Access completely stops the Sub at this point. When I manually change the Excel cell to [text A text] or the '' to ``, everything works perfectly again. But having to manually changing the source Excel defeats the purpose.
How do I import an Excel sheet when one or more cells contain [ 'A' ]?
Thank you in advance for any help.
'This checks if file exsist, imports file, then imports any sequential files.
Option Explicit
Public Sub ImportXL2(bolJustExcelFile As Boolean, Optional bolRefresh As Boolean)
Dim rstXL As DAO.Recordset
Dim x As Integer, y As Long
Dim strPath1 As String, strPath2 As String
Dim strPN As String, strDescription As String, strPrime As String
Dim intOHB As Integer, sngCost As Single, intMin As Integer, intMax As Integer
Dim strCode As Integer, strNumber As String, strDate As String, strQty As Integer, strRepairable As String, strEntity As String
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM ExcelFile"
If bolJustExcelFile = False Then
DoCmd.RunSQL "DELETE FROM ExcelFileCombined"
End If
For x = 1 To 10
DoCmd.RunSQL "DELETE FROM ExcelFiletemp"
strPath1 = Environ("userprofile") & "\Desktop\Folder\ExcelFile.xlsx"
strPath2 = Environ("userprofile") & "\Desktop\Folder\ExcelFile" & x & ".xlsx"
If x = 1 Then
If FileExists(strPath1) = -1 Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "ExcelFiletemp", strPath1, False, "A:L"
Else
If bolRefresh = True Then
MsgBox "ExcelFile File Not Found", , "Missing ExcelFile File"
End If
Exit For
End If
Else
If FileExists(strPath2) = -1 And bolJustExcelFile = False Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "ExcelFiletemp", strPath2, False, "A:L"
Else
GoTo SkipXL
End If
End If
Set rstXL = CurrentDb.OpenRecordset("SELECT * FROM ExcelFiletemp", dbOpenSnapshot)
rstXL.MoveLast
rstXL.MoveFirst
For y = 1 To 4
rstXL.MoveNext
Next y
strEntity = Right(rstXL![F1], 6)
For y = 1 To 4
rstXL.MoveNext
Next y
On Error GoTo ErrHandler
For y = 1 To rstXL.RecordCount - 8
strPN = rstXL![F1]
strDescription = rstXL![F2]
strPrime = rstXL![F3]
intOHB = rstXL![F4]
sngCost = rstXL![F5]
intMin = rstXL![F6]
intMax = rstXL![F7]
strCode = rstXL![F8]
strRepairable = rstXL![F12]
If x = 1 Then
DoCmd.RunSQL "INSERT INTO ExcelFile (PN, Description, Prime, OHB, Cost, Min, Max, Code, Repairable, Entity) VALUES ('" & strPN & "','" & strDescription & "','" & strPrime & "'," & intOHB & "," & sngCost & "," & intMin & "," & intMax & "," & strCode & ",'" & strRepairable & "','" & strEntity & "');"
End If
If bolJustExcelFile = False Then
DoCmd.RunSQL "INSERT INTO ExcelFileCombined (PN, Description, Prime, OHB, Cost, Min, Max, Code, Repairable, Entity) VALUES ('" & strPN & "','" & strDescription & "','" & strPrime & "'," & intOHB & "," & sngCost & "," & intMin & "," & intMax & "," & strCode & ",'" & strRepairable & "','" & strEntity & "');"
End If
rstXL.MoveNext
Next y
rstXL.Close
SkipXL:
Next x
Set rstXL = Nothing
DoCmd.SetWarnings True
ErrHandler:
If Err.Number = 94 Then 'Invalid use of Null
rstXL.MoveNext
End If
End Sub
You can escape single quotes by doubling them up.
Function EscQ(text As String)
EscQ = Replace(text, "'", "''")
End Function
Usage:
DoCmd.RunSQL "INSERT INTO ExcelFileCombined (PN, Description, Prime, OHB, Cost, Min, Max, Code, Repairable, Entity) VALUES ('" & EscQ(strPN) & "','" & EscQ(strDescription) & "','" & EscQ(strPrime) & "'," & intOHB & "," & sngCost & "," & intMin & "," & intMax & "," & strCode & ",'" & EscQ(strRepairable) & "','" & EscQ(strEntity) & "');"
I think using recordset to add new record will somehow make you worry free about SQL Syntax getting wrong because of special characters e.g. single or double quotes. You can try add a function:
Function insrt_item(rstXL as DAO.Recordset, tbl_dest as String) ' set tbl_dest to ExcelFile or ExcelFileCombined since they are same fields anyway
With currentdb.OpenRecordSet(tbl_dest)
.AddNew
!PN = rstXL!F1
!Description = rstXL!F2
'.. add more fields here
.Update
.Close
End With
End Function
I have the following DCount code in my VBA:
If DCount("*", "tbl2Employee_Order", _
"[Operation_Date] = #" & Operation_Date & _
"# AND [Employee_ID]= " & Employee_ID & _
" AND [Order_ID] = " & Order_ID & _
" AND [Model_Operation_ID] = " & MO_ID) = 0 Then
'some code to insert into tbl2Employee_Order
Else
'some code to update the existing record
End If
However, my DCount always returns 0, even if the record already exists. The following:
Debug.Print Operation_Date, Employee_ID, Order_ID, MO_ID, DCount("*", "tbl2Employee_Order", "[Operation_Date] = #" & Operation_Date & "# AND [Employee_ID]= " & Employee_ID & " AND [Order_ID] = " & Order_ID & " AND [Model_Operation_ID] = " & MO_ID)
Returns the expected values such as:
08/05/2015 2 526 1107 0
Apart from the last one, which is expected to be 1 (record already exists).
tbl2EmployeeOrder has this record:
Operation_Date: 08/05/2015
Employee_ID: 2
Order_ID: 526
Model_Operation_ID = 1107
Interestingly enough, it used to work without problem a few weeks ago, suddenly it behaves as if the record doesn't already exist.
Edit:
The following:
Debug.Print TypeName(Operation_Date), TypeName(Employee_ID), TypeName(Order_ID), TypeName(MO_ID)
Results in:
Date Integer Integer Integer
And those are also the variable types in the tbl2Employee_Order.
Similarly, if I use DLookup (with some column name) instead of DCount I get a Null value returned.
did you change regional settings ? how about
If DCount("*", "tbl2Employee_Order", _
"[Operation_Date] = #" & Format(Operation_Date,"mm/dd/yyyy") & _
"# AND [Employee_ID]= " & Employee_ID & _
" AND [Order_ID] = " & Order_ID & _
" AND [Model_Operation_ID] = " & MO_ID) = 0 Then
remove the date criteria to see if it works
I can store records in the DB by using combobox with the following code.
Here single part number is selected and partnumber related data is stored in the DB table.
But I want the code for Listbox...When I select multiple partnumbers ..how can I store in the DB table?
Case "Pn ADDED to Wrapper", _
"Pn REMOVED from Wrapper"
If Me!PartNumber <> "All" And Me!PartNumber <> "Select" Then ' a proper part number has been selected in combo box
strNewSq5 = _
"INSERT INTO tblTmpEventLog (TrackingNumber,PartNumber,PartNumberChgLvl,EnteredBy,EventTypeSelected,EventDate)"
strNewSq5 = strNewSq5 & " VALUES ('" & tempTrackingNumber & "','" & _
tempPartNumber & "','" & _
tempPartNumberChgLvl & "','" & _
tempEnteredBy & "','" & _
tempEventTypeSelected & "'," & _
"#" & Forms!frmEventLog_Input.EventDate & "#)"
dbs.Execute strNewSq5, dbFailOnError
TrnsfTmpEventToEventLog
Else
displayMsgBox = MsgBox("A single part number must be specified. Please correct.", vbCritical, "System Error")
Exit Sub
End If
You need to iterate over the selected items and store them one by one:
MS Access 2007 - Cycling through values in a list box to grab id's for a SQL statement
EDIT re comment
You do not provide sufficient information for a detailed answer, but here are some notes that may help.
For Each itm In Me.NameOfListBox.ItemsSelected
If Instr("All,Select",Me.NameOfListBox.Column(0, itm) )=0 Then
'' a proper part number has been selected in list box
'' Me.NameOfListBox.Column(0, itm) is the column (zero in this example
'' and row (itm) of the selected item in the list box. If it is the
'' part number, then you might like to say:
'' tempPartNumber = Me.NameOfListBox.Column(0, itm)
strNewSq5 = "INSERT INTO tblTmpEventLog " & _
"(TrackingNumber,PartNumber,PartNumberChgLvl,EnteredBy," & _
"EventTypeSelected,EventDate)"
strNewSq5 = strNewSq5 & " VALUES ('" & tempTrackingNumber & "','" & _
tempPartNumber & "','" & _
tempPartNumberChgLvl & "','" & _
tempEnteredBy & "','" & _
tempEventTypeSelected & "'," & _
"#" & Forms!frmEventLog_Input.EventDate & "#)"
dbs.Execute strNewSq5, dbFailOnError
TrnsfTmpEventToEventLog
Else
''Do not insert
End If
Next