Please find my below sample table,where i have applying if condition for multiplying Numerical data.
Query Code
sql_string = "Select [Sheet5$].[num] * IIf(([Sheet5$].[to]-[Sheet5$].[frm])<365, .4," & _
"IIf(([Sheet5$].[to]-[Sheet5$].[frm])>365, 1, 0)) from [Sheet5$]"
Above code will help me out to apply the condition on one column i.e num only.But i want to apply it on multiple columns around 20-30 columns which is available in my actual data.it is possible to mention column names but it is not possible to write the above if condition to each column. please guide me on the same.
Do you mean something like this?
Public Sub test()
Dim sql_string As String
Dim sheet_name As String
sheet_name = "Sheet5$"
sql_string = "Select "
sql_string = sql_string & GetField(sheet_name, "num") & ","
sql_string = sql_string & GetField(sheet_name, "num1") & ","
sql_string = sql_string & GetField(sheet_name, "num2") & ","
sql_string = sql_string & GetField(sheet_name, "num3")
sql_string = sql_string & " from [" & sheet_name & "]"
Debug.Print sql_string
End Sub
Public Function GetField(ByVal sheet_name As String, ByVal fieldName As String)
GetField = "[" & sheet_name & "].[" & fieldName & "] * IIf(([" & sheet_name & "].[to] - [" & sheet_name & "].[frm]) < 365, 0.4, IIf(([" & sheet_name & "].[to] - [" & sheet_name & "].[frm]) > 365, 1, 0))"
End Function
Result:
Select [Sheet5$].[num] * IIf(([Sheet5$].[to] - [Sheet5$].[frm]) < 365, 0.4, IIf(([Sheet5$].[to] - [Sheet5$].[frm]) > 365, 1, 0)),
[Sheet5$].[num1] * IIf(([Sheet5$].[to] - [Sheet5$].[frm]) < 365, 0.4, IIf(([Sheet5$].[to] - [Sheet5$].[frm]) > 365, 1, 0)),
[Sheet5$].[num2] * IIf(([Sheet5$].[to] - [Sheet5$].[frm]) < 365, 0.4, IIf(([Sheet5$].[to] - [Sheet5$].[frm]) > 365, 1, 0)),
[Sheet5$].[num3] * IIf(([Sheet5$].[to] - [Sheet5$].[frm]) < 365, 0.4, IIf(([Sheet5$].[to] - [Sheet5$].[frm]) > 365, 1, 0)) from [Sheet5$]
Related
I have a string in this format similar to the json. Generated by the following code:
str = "{"
str &= Chr(34) & "code" & Chr(34) + ":" & Chr(34) & "0000001" & Chr(34)
str &= Chr(34) & "name" & Chr(34) + ":" & Chr(34) & "product 1" & Chr(34)
str &= Chr(34) & "value" & Chr(34) + ":" & Chr(34) & "150.00" & Chr(34)
str &= "}"
I just need to get the value after the code, name and value.
I cannot find an effective method to do this, as I will have to generalize to more terms later. How can I do this without transforming to JSON?
The code snippet you provide produces this string:
{"code":"0000001""name":"product 1""value":"150.00"}
Assuming you really are using VB6 to process this string, the following code breaks out the values:
Private Sub Test(ByVal str As String)
Dim groups As Variant
Dim values As Variant
Dim i As Integer
str = Replace(str, "{", "")
str = Replace(str, "}", "")
str = Replace(str, """""", ",")
str = Replace(str, """", "")
groups = Split(str, ",")
For i = LBound(groups) To UBound(groups)
values = Split(groups(i), ":")
Debug.Print values(1)
Next
End Sub
Something like this should help (untested):
colon% = 0
Dim completed as Boolean
while completed = false
colon% = InStr(colon% + 1, str, ":")
If colon% > 0 Then
value$ = Mid$(str, colon + 1, InStr(colon% + 2, str, Chr(34)) - colon%)
' ... do whatever with value$ here...
Else
completed = true
End If
Wend
I am generating some HTML in VBA (MSACCESS), which works fine but it is a bit of a mess from an indentation point of view.
Is there an easy way to indent a stream of HTML text in VBA?
I use Visual Studio Code format functionality to have a prettier HTML, but I have to do this by hand and it is very tedious!
Example:
<div class="anythinggoes">
<ul><li>A</li>
<li>B</li><li>C</li>
</ul></div> <!-- anythinggoes -->
Should become something like:
<div class="anythinggoes">
<ul>
<li>A</li>
<li>B</li>
<li>C</li>
</ul>
</div> <!-- anythinggoes -->
Any help will be much appreciated!
CAUTION! Ugly code ahead!
Welcome on board, RichD. I think this code might help you:
First, define these variables in the Module scope:
Private InlineTags As Variant
Private InlineClosingTags As Variant
Private LineBreakTags As Variant
Then, we can use this function:
Function ReadableHTML(HTML As String) As String
Dim a$, i&, TabsNo&, tabs$, l&, tag$, MaxTabs&
'add here tags that you want to keep on the same line of their parent
InlineTags = Array("!--", "a", "i", "b", "sup", "sub", "strong") 'never followed by a line break
InlineClosingTags = Array("li", "h1", "h2", "h3", "h4") 'always followed by a line break
LineBreakTags = Array("br", "br/", "br /") 'always lead & followed by a line break
a = CleanOf(HTML)
TabsNo = -1
i = 1
l = Len(a)
Do While i < l
If Mid(a, i, 2) = "</" Then
tag = Mid(a, i + 2, InStr(i + 2, a, ">") - i - 2)
If Not IsInArray(tag, InlineClosingTags) Or Mid(a, i - 1, 1) = ">" Then
tabs = Chr(10) & Filler(TabsNo, Chr(9))
a = Left(a, i - 1) & tabs & Right(a, Len(a) - i + 1)
l = Len(a)
i = i + Len(tabs)
End If
TabsNo = TabsNo - 1
Else
Select Case Mid(a, i, 1)
Case "<"
tag = Mid(a, i + 1, InStr(i + 1, a, ">") - i - 1)
If Not IsInArray(tag, InlineTags) Then
TabsNo = TabsNo + 1
If TabsNo > MaxTabs Then MaxTabs = TabsNo
If i > 1 Then tabs = Chr(10) & Filler(TabsNo, Chr(9)) Else tabs = Filler(TabsNo, Chr(9))
' tabs = tabs & Filler(TabsNo, Chr(9))
a = Left(a, i - 1) & tabs & Right(a, Len(a) - i + 1)
l = Len(a)
i = i + Len(tabs)
If IsInArray(tag, LineBreakTags) Then TabsNo = TabsNo - 1
End If
Case ">"
tag = Mid(a, InStrRev(a, "<", i) + 1, i - InStrRev(a, "<", i) - 1)
If Not IsInArray(tag, InlineClosingTags) Then
tabs = Chr(10) & Filler(TabsNo + 1, Chr(9))
a = Left(a, i) & tabs & Right(a, Len(a) - i)
End If
Case Chr(10)
If Mid(a, i + 1, 1) <> Chr(9) And Mid(a, i + 1, 1) <> "<" Then
tabs = Chr(10) & Filler(TabsNo + 1, Chr(9))
a = Left(a, i) & tabs & Right(a, Len(a) - i)
l = Len(a)
i = i + Len(tabs)
End If
End Select
End If
i = i + 1
Loop
For TabsNo = MaxTabs To 0 Step -1
a = Replace(a, Chr(10) & Filler(TabsNo, Chr(9)) & Chr(10), Chr(10))
Next
ReadableHTML = treatInlineTags(a, False)
End Function
Which uses these helping functions:
Function treatInlineTags(a As String, HideFlag As Boolean)
'Hides/unhides inline tags from CleanOf
If HideFlag Then
For i = LBound(InlineTags) To UBound(InlineTags)
a = Replace(a, "<" & InlineTags(i) & " ", "|" & InlineTags(i) & "¦")
a = Replace(a, "<" & InlineTags(i) & ">", "|" & InlineTags(i) & "|")
a = Replace(a, "</" & InlineTags(i) & ">", "|/" & InlineTags(i) & "|")
Next i
Else
For i = LBound(InlineTags) To UBound(InlineTags)
a = Replace(a, "|" & InlineTags(i) & "¦", "<" & InlineTags(i) & " ")
a = Replace(a, "|" & InlineTags(i) & "|", "<" & InlineTags(i) & ">")
a = Replace(a, "|/" & InlineTags(i) & "|", "</" & InlineTags(i) & ">")
Next i
End If
treatInlineTags = a
End Function
Function IsInArray(a As String, Arr As Variant) As Boolean
Dim i As Long
For i = LBound(Arr) To UBound(Arr)
IsInArray = a = Arr(i)
If IsInArray Then Exit Function
Next i
End Function
Function CleanOf(a As String) As String
'Removes unwanted spaces between tags
Dim i As Long, b As Boolean, l As Long
a = Replace(a, Chr(13), "")
a = Replace(a, Chr(10), "")
a = treatInlineTags(a, True)
For i = 1 To Len(a)
Select Case Mid(a, i, 1)
Case ">", "<"
If i - l > 1 And l > 0 Then a = Left(a, l) & Right(a, Len(a) - i + 1)
If i > 1 Then l = i
If l > 0 Then b = True
Case Is <> " "
b = False
l = 0
End Select
Next i
CleanOf = a
End Function
Function Filler(n As Long, Optional Str As String = "0") As String
If n > 0 Then Filler = Replace(Space$(n), " ", Str)
End Function
To test it:
Sub test()
Dim a As String, b As String
a = "<div class=""myclass""> " & Chr(13) & _
"<ul><li>A</li> " & Chr(13) & _
"<li>B</li><li>C</li> " & _
"</ul></div> <!-- just a comment -->" & _
"<h2 class=""mytitle"">a title: inline and " & _
"followed by a line break</h2>" & _
"<div><ul><li><i class=""myitalic"">italic " & _
"content: inline and NOT followed by a line break</i>" & _
"</li></ul></div>"
b = "<li><i class=""mylist""></i>a list <ul>" & _
"<li>element 1</li><li>element 2</li><li>element 3</li></ul> " & _
"</li><li>This <b>is bold</b> in an element list " & _
"<a href=""#mydestination"">""with an href"" " & _
"</a></li>"
Debug.Print Chr(10) & "Test1 - input:" & Chr(10) & a
Debug.Print Chr(10) & "Test1 - output:" & Chr(10) & ReadableHTML(a)
Debug.Print Chr(10) & "Test2 - input:" & Chr(10) & b
Debug.Print Chr(10) & "Test2 - output:" & Chr(10) & ReadableHTML(b)
End Sub
I've written some VBA code that (a) sets the SQL of a query based on input variables, (b) opens the query in datasheet view, and (c) hides or shows columns based on "true" / "false" values of check boxes in another table. This is considering the "ColumnHidden" property as described in Microsoft Dev Center help. Dev Center Help - ColumnHidden Property
When executing the code, (a) and (b) are working as intended. However, I get error 3270, "Property not found" at line fld.Properties("ColumnHidden") = False when executing (c). I've been unable to resolve the issue, even when trying the error handling method described in the Dev Center. Please help!
Dim rsLabel As DAO.Recordset, rsCOlumn As DAO.Recordset
Dim qryCPQ As DAO.QueryDef
Dim strLabel As String, strSQL As String, strColumn As String
Dim fld As DAO.Field
Dim dbs As DAO.Database
Dim prp As DAO.Property
Dim AttArray As Variant
Dim x As Integer
ReDim AttArray(19, 1)
For x = 1 To 20
AttArray(x - 1, 1) = "Att" & x
Next x
strLabel = "SELECT * FROM PM_qryLabels2 WHERE CAT_ID=" & Forms!CM_frmCollectionReportPre!cboFamily
Set rsLabel = CurrentDb.OpenRecordset(strLabel, dbOpenSnapshot)
rsLabel.MoveFirst
For x = 1 To 20
If Not IsNull(rsLabel.Fields("Att" & x)) Then
AttArray(x - 1, 1) = rsLabel.Fields("Att" & x)
Else
AttArray(x - 1, 1) = "Att" & x
End If
Next x
With CurrentDb
Set qryCPQ = .QueryDefs("CM_qryCollectionReport")
strSQL = "SELECT CM_qryCollectionEdit2.CATEGORY, CM_qryCollectionEdit2.Part_No, CM_qryCollectionEdit2.CPQ_Material, CM_qryCollectionEdit2.CPQ_LaborMach, CM_qryCollectionEdit2.CPQ_LaborAssy, CM_qryCollectionEdit2.CPQ_LaborPipe, CM_qryCollectionEdit2.CPQ_LaborTest, CM_qryCollectionEdit2.CPQ_LaborPack, CM_qryCollectionEdit2.CPQ_LaborShip, CM_qryCollectionEdit2.CPQ_Sub, " & _
"PM_qryOptions.Att1 As [" & AttArray(0, 1) & "], PM_qryOptions.Att2 As [" & AttArray(1, 1) & "], PM_qryOptions.Att3 As [" & AttArray(2, 1) & "], PM_qryOptions.Att4 As [" & AttArray(3, 1) & "], PM_qryOptions.Att5 As [" & AttArray(4, 1) & "], PM_qryOptions.Att6 As [" & AttArray(5, 1) & "], PM_qryOptions.Att7 As [" & AttArray(6, 1) & "], PM_qryOptions.Att8 As [" & AttArray(7, 1) & "], PM_qryOptions.Att9 As [" & AttArray(8, 1) & "], PM_qryOptions.Att10 As [" & AttArray(9, 1) & "], PM_qryOptions.Att11 As [" & AttArray(10, 1) & "], PM_qryOptions.Att12 As [" & AttArray(11, 1) & "], PM_qryOptions.Att13 As [" & AttArray(12, 1) & "], PM_qryOptions.Att14 As [" & AttArray(13, 1) & "], PM_qryOptions.Att15 As [" & AttArray(14, 1) & "], PM_qryOptions.Att16 As [" & AttArray(15, 1) & "], PM_qryOptions.Att17 As [" & AttArray(16, 1) & "], PM_qryOptions.Att18 As [" & AttArray(17, 1) & "], PM_qryOptions.Att19 As [" & AttArray(18, 1) & "], PM_qryOptions.Att20 As [" & AttArray(19, 1) & "] " & _
"FROM CM_qryCollectionEdit2 INNER JOIN PM_qryOptions ON CM_qryCollectionEdit2.Part_No = PM_qryOptions.Part_No " & _
"WHERE ((CM_qryCollectionEdit2.CAT_ID)=" & Me.cboFamily & " AND ((CM_qryCollectionEdit2.CPQ_Publish)=True));"
qryCPQ.SQL = strSQL
qryCPQ.Close
Set qryCPQ = Nothing
End With
DoCmd.OpenQuery "CM_qryCollectionReport", , acReadOnly
Set dbs = CurrentDb
For x = 1 To 20
Set fld = dbs.QueryDefs!CM_qryCollectionReport.Fields(AttArray(x - 1, 1))
fld.Properties("ColumnHidden") = False
strColumn = "SELECT * FROM PM_Attributes WHERE CAT_ID=" & Forms!CM_frmCollectionReportPre!cboFamily & " AND [ATTRIBUTE]='" & AttArray(x - 1, 1) & "'"
Set rsCOlumn = CurrentDb.OpenRecordset(strColumn, dbOpenSnapshot)
If Not rsCOlumn.EOF Then
If rsCOlumn![CPQ_Publish] = False Then
fld.Properties("ColumnHidden") = True
End If
End If
rsCOlumn.Close
Set rsCOlumn = Nothing
Set fld = Nothing
Next x
Set dbs = Nothing
DoCmd.Close acForm, "CM_frmCollectionReportPre", acSaveNo
Per Eric Von Asmuth's suggestion, I've added in the error handling, so the code now appears as follows. Yet I still receive error 3270 at the same location. Hasn't fixed a thing.
Dim rsLabel As DAO.Recordset, rsCOlumn As DAO.Recordset
Dim qryCPQ As DAO.QueryDef
Dim strLabel As String, strSQL As String, strColumn As String
Dim fld As DAO.Field
Dim dbs As DAO.Database
Dim prp As DAO.Property
Dim AttArray As Variant
Dim x As Integer
Const conErrPropertyNotFound = 3270
' Turn off error trapping
On Error Resume Next
ReDim AttArray(19, 1)
For x = 1 To 20
AttArray(x - 1, 1) = "Att" & x
Next x
strLabel = "SELECT * FROM PM_qryLabels2 WHERE CAT_ID=" & Forms!CM_frmCollectionReportPre!cboFamily
Set rsLabel = CurrentDb.OpenRecordset(strLabel, dbOpenSnapshot)
rsLabel.MoveFirst
For x = 1 To 20
If Not IsNull(rsLabel.Fields("Att" & x)) Then
AttArray(x - 1, 1) = rsLabel.Fields("Att" & x)
Else
AttArray(x - 1, 1) = "Att" & x
End If
Next x
'AFTER FORM IS OPEN, NEED TO HIDE COLUMNS BASEDON CPQ_PUBLISH
With CurrentDb
Set qryCPQ = .QueryDefs("CM_qryCollectionReport")
strSQL = "SELECT CM_qryCollectionEdit2.CATEGORY, CM_qryCollectionEdit2.Part_No, CM_qryCollectionEdit2.CPQ_Material, CM_qryCollectionEdit2.CPQ_LaborMach, CM_qryCollectionEdit2.CPQ_LaborAssy, CM_qryCollectionEdit2.CPQ_LaborPipe, CM_qryCollectionEdit2.CPQ_LaborTest, CM_qryCollectionEdit2.CPQ_LaborPack, CM_qryCollectionEdit2.CPQ_LaborShip, CM_qryCollectionEdit2.CPQ_Sub, " & _
"PM_qryOptions.Att1 As [" & AttArray(0, 1) & "], PM_qryOptions.Att2 As [" & AttArray(1, 1) & "], PM_qryOptions.Att3 As [" & AttArray(2, 1) & "], PM_qryOptions.Att4 As [" & AttArray(3, 1) & "], PM_qryOptions.Att5 As [" & AttArray(4, 1) & "], PM_qryOptions.Att6 As [" & AttArray(5, 1) & "], PM_qryOptions.Att7 As [" & AttArray(6, 1) & "], PM_qryOptions.Att8 As [" & AttArray(7, 1) & "], PM_qryOptions.Att9 As [" & AttArray(8, 1) & "], PM_qryOptions.Att10 As [" & AttArray(9, 1) & "], PM_qryOptions.Att11 As [" & AttArray(10, 1) & "], PM_qryOptions.Att12 As [" & AttArray(11, 1) & "], PM_qryOptions.Att13 As [" & AttArray(12, 1) & "], PM_qryOptions.Att14 As [" & AttArray(13, 1) & "], PM_qryOptions.Att15 As [" & AttArray(14, 1) & "], PM_qryOptions.Att16 As [" & AttArray(15, 1) & "], PM_qryOptions.Att17 As [" & AttArray(16, 1) & "], PM_qryOptions.Att18 As [" & AttArray(17, 1) & "], PM_qryOptions.Att19 As [" & AttArray(18, 1) & "], PM_qryOptions.Att20 As [" & AttArray(19, 1) & "] " & _
"FROM CM_qryCollectionEdit2 INNER JOIN PM_qryOptions ON CM_qryCollectionEdit2.Part_No = PM_qryOptions.Part_No " & _
"WHERE ((CM_qryCollectionEdit2.CAT_ID)=" & Me.cboFamily & " AND ((CM_qryCollectionEdit2.CPQ_Publish)=True));"
qryCPQ.SQL = strSQL
qryCPQ.Close
'Set qryCPQ = Nothing
End With
DoCmd.OpenQuery "CM_qryCollectionReport", , acReadOnly
Set dbs = CurrentDb
For x = 1 To 20
Set fld = dbs.QueryDefs!CM_qryCollectionReport.Fields(AttArray(x - 1, 1))
fld.Properties("ColumnHidden") = False
' Error may have occurred when value was set.
' Display error message or create property when property didn't exist
If Err.Number <> 0 Then
If Err.Number <> conErrPropertyNotFound Then
On Error GoTo 0
MsgBox "Couldn't set property 'ColumnHidden' " & _
"on field '" & fld.Name & "'", vbCritical
Else
On Error GoTo 0
Set prp = fld.CreateProperty("ColumnHidden", dbLong, False)
fld.Properties.Append prp
End If
End If
strColumn = "SELECT * FROM PM_Attributes WHERE CAT_ID=" & Forms!CM_frmCollectionReportPre!cboFamily & " AND [ATTRIBUTE]='" & AttArray(x - 1, 1) & "'"
Set rsCOlumn = CurrentDb.OpenRecordset(strColumn, dbOpenSnapshot)
If Not rsCOlumn.EOF Then
If rsCOlumn![CPQ_Publish] = False Then
fld.Properties("ColumnHidden") = True
End If
End If
rsCOlumn.Close
Set rsCOlumn = Nothing
Set fld = Nothing
Set prp = Nothing
Next x
Set dbs = Nothing
DoCmd.Close acForm, "CM_frmCollectionReportPre", acSaveNo
Screen shots of error:
If you closely look at the example code in the article you referred to, it includes error capturing, and creating the property if it didn't exist. This is because the property may or may not exist based on unpredictable circumstances.
Adapted from the Linked article:
Const conErrPropertyNotFound = 3270
' Turn off error trapping.
On Error Resume Next
'Set the field to false here
fld.Properties("ColumnHidden") = False
' Error may have occurred when value was set.
' Display error message or create property when property didn't exist
If Err.Number <> 0 Then
If Err.Number <> conErrPropertyNotFound Then
On Error GoTo 0
MsgBox "Couldn't set property 'ColumnHidden' " & _
"on field '" & fld.Name & "'", vbCritical
Else
On Error GoTo 0
Set prp = fld.CreateProperty("ColumnHidden", dbLong, False)
fld.Properties.Append prp
End If
End If
Since you've already set the field to False, you don't need to error trap in case the field doesn't exist when setting it back to True
You can also choose to check if the property does exist by iterating through all properties, which is best done in a separate function. This avoids error trapping, but may take longer to run
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 want to run a script in my macro multiple times by changing variable values.
Below is an example of my code that I run for one value.
The line of code I would like to change is
sScript = sScript + "where m.outletid in ('" & sOutletId & "') " & vbCrLf
Sometime I want the where clause to be
where m.outletid in ('12314')
or
where m.chainid in ('411')...
Code:
Sub Report()
Dim sScript As String
Dim sServer As String
Dim sDatabase As String
Dim sTransTable As String
Dim iVal As Integer
Dim iReturnVal As Integer
Dim SheetExists As Worksheet
Dim WK_SHEET As String
sServer = Trim(UserForm1.txtServer.Value)
sDatabase = Trim(UserForm1.txtDatabase.Value)
sTransTable = Trim(UserForm1.txtTransTable.Value)
For Each SheetExists In Worksheets
If SheetExists.Name = ("Report") Then
Application.DisplayAlerts = False
Sheets("Report").Delete
Application.DisplayAlerts = True
Exit For
End If
Next SheetExists
Worksheets.Add after:=Sheets("Sheet1")
ActiveSheet.Name = ("Report")
WK_SHEET = "Report"
Sheets(WK_SHEET).Select
sOutletId = "12314"
sScript = "Select top 10 m.CustNumber, m.Name, sum(t.Transvalue) " & vbCrLf
sScript = sScript + "from " & sTransTable & " t " & vbCrLf
sScript = sScript + "where m.outletid in ('" & sOutletId & "') " & vbCrLf
sScript = sScript + "Group by m.CustNumber, m.Name " & vbCrLf
sScript = sScript + "order by sum(t.Transvalue)Desc " & vbCrLf
iReply = MsgBox(Prompt:="Do you wish to continue with the following script for Top 10 Customers?" + sScript + "", _
Buttons:=vbYesNo, Title:="Run MACRO Top 10 Reports")
If iReply = vbNo Then
End
End If
iVal = execute_sql_select(WK_SHEET, 2, 1, sServer, sDatabase, sScript)
Sheets(WK_SHEET).Name = "Outlet" & sOutletId & "Top 10 by Spend"
Now I would like to re run the above with OutletId 12315...how can I do this? Do I use some sort of loop?
You can keep list of OutletId into Array. Then get each OutletId from Array (for loop) and execute your sql script.
Pseudu code
Array listOutid = new Array[12,13,14,15];
for(int idx = 0; idx < listOutid.Length; idx++)
{
var OutletId = listOutid[idx];
//put ur sql statement and execute here..
}