say I have a table with column A, B & C and I have the following codes to find the column names and I want to join these names as array like "A B C". However, it returns with subscript out of range run time error9. What I should do to get rid of this error? Thanks in advance!
Option Compare Database
Private Sub check_tbl2_Click()
Dim ind() As String
Dim joinInd As String
Dim l As Integer
For l = 0 To CurrentDb.TableDefs("tbl2").Fields.Count - 1
MsgBox (CurrentDb.TableDefs("tbl2").Fields(l).Name)
ind(l) = CurrentDb.TableDefs("tbl2").Fields(l).Name
Next l
joinInd = Join(ind)
MsgBox (joinInd)
End Sub
You never set the dimensions for ind(). Here's one way to do it. Look at the redim statement.
Sub check_tbl2_Click()
Dim ind() As String
Dim joinInd As String
Dim l As Integer
ReDim ind(CurrentDb.TableDefs("tbl2").Fields.Count - 1)
For l = 0 To CurrentDb.TableDefs("tbl2").Fields.Count - 1
MsgBox (CurrentDb.TableDefs("tbl2").Fields(l).Name)
ind(l) = CurrentDb.TableDefs("tbl2").Fields(l).Name
Next l
joinInd = Join(ind)
MsgBox (joinInd)
End Sub
This should work for you:
EDIT: Actually, Tom Collins' answer is much better if you decide to keep with the array method, so don't use this. I wasn't thinking most efficiently.
Private Sub check_tbl2_Click()
Dim ind() As String
Dim joinInd As String
Dim l As Integer
ReDim ind(1)
For l = 0 To CurrentDb.TableDefs("tbl2").Fields.Count - 1
'MsgBox (CurrentDb.TableDefs("tbl2").Fields(l).Name)
ReDim Preserve ind(UBound(ind) + 1)
ind(l) = CurrentDb.TableDefs("tbl2").Fields(l).Name
Next l
joinInd = Join(ind)
MsgBox (joinInd)
End Sub
but why not just:
Private Sub check_tbl2_Click()
Dim joinInd As String
Dim db As DAO.Database
Dim fld As DAO.Field
Set db = CurrentDb()
For Each fld In db.TableDefs("tbl2").Fields
joinInd = joinInd & fld.Name
Next
MsgBox (joinInd)
Set db = Nothing
End Sub
Related
I have the below code used to capture the selected values from listbox in msaccess. All I'm getting is only the index value but not the actual value which is a string value.
eg. if my listbox contains values like XXX,AAA,BBB and if i select XXX the code is fetching the index value of XXX as 0 and using it every where. But my expectation is to capture and store XXX as value.
Private Sub Create_Invoice_Click()
On Error GoTo Err_Create_Invoice_Click
Dim xlWorksheetPath As String
Dim dbTable As String
Dim dbTablee As String
Dim BaCode As String
Dim lst As ListBox
Set lst = Me.BA_CD
Dim rowcount As Long
Dim oItem As Variant
Dim iCount As Integer
If lst.ItemsSelected.Count <> 0 Then
For Each oItem In lst.ItemsSelected
If iCount = 0 Then
BaCode = BaCode & lst.ItemData(oItem)
iCount = iCount + 1
Else
BaCode = BaCode & "," & lst.ItemData(oItem)
iCount = iCount + 1
End If
Next oItem
Else
MsgBox "Nothing was selected from the list"
Exit Sub 'Nothing was selected
End If
xlWorksheetPath = "systempath\"
xlWorksheetPath = xlWorksheetPath & BaCode & ".xls"
dbTable = "table1"
dbTablee = "table2"
DoCmd.TransferSpreadsheet transfertype:=acExport, spreadsheettype:=acSpreadsheetTypeExcel12, tablename:=dbTable, filename:=xlWorksheetPath, hasfieldnames:=True
DoCmd.TransferSpreadsheet transfertype:=acExport, spreadsheettype:=acSpreadsheetTypeExcel12, tablename:=dbTablee, filename:=xlWorksheetPath, hasfieldnames:=True
MsgBox "Data trasfered successfully"
Exit_Create_Invoice_Click:
Exit Sub
Err_Create_Invoice_Click:
MsgBox Err.Description`enter code here`
Resume Exit_Create_Invoice_Click
End Sub
In the listbox, column 0 should be the ID of the selected value, and is the value being selected with lst.ItemData(oItem).
Column 1 would be the first visible value in the list.
Try changing lst.ItemData(oItem) to lst.Column(1, oItem)
i am trying to get the frequency of terms within a collection of variable length strings.The context is descriptions in an Access database. Would prefer to keep the solution in VBA. Delimiter is " " (space) character
Dim db As DAO.Database
Set db = CurrentDb()
Call wordfreq
End Sub
Function wordfreq()
Dim myCol As Collection
Dim myArray() As String
Dim strArray As Variant
Dim strDescr, strTerm, strMsg As String
Dim i, j As Integer
Set myCol = New Collection
strDescr = "here it should accept the table and display the result in seperate table"
' db.Execute "select columns from table"
myArray = Split(strDescr, " ")
For Each strArray In myArray
On Error Resume Next
myCol.Add strArray, CStr(strArray)
Next strArray
For i = 1 To myCol.Count
strTerm = myCol(i)
j = 0
For Each strArray In myArray
If strArray = strTerm Then j = j + 1
Next strArray
'placeholder
strMsg = strMsg & strTerm & " --->" & j & Chr(10) & Chr(13)
Next i
'placeholder
'save results into a table
MsgBox strMsg
End Function
See an example below using a Scripting.Dictionary object.
Function wordfreq()
Dim objDict As Object
Dim myArray() As String
Dim strInput As String
Dim idx As Long
Set objDict = CreateObject("Scripting.Dictionary")
strInput = "here it should accept the table and display the result in seperate table"
myArray = Split(strInput, " ")
For idx = LBound(myArray) To UBound(myArray)
If Not objDict.Exists(myArray(idx)) Then
'Add to dictionary with a count of 1
objDict(myArray(idx)) = 1
Else
'Increment counter
objDict(myArray(idx)) = objDict(myArray(idx)) + 1
End If
Next
'Test it
Dim n As Variant
For Each n In objDict.Keys
Debug.Print "Word: " & n, " Count: " & objDict(n)
Next
End Function
Output:
'Word: here Count: 1
'Word: it Count: 1
'Word: should Count: 1
'Word: accept Count: 1
'Word: the Count: 2
'Word: table Count: 2
'Word: and Count: 1
'Word: display Count: 1
'Word: result Count: 1
'Word: in Count: 1
'Word: seperate Count: 1
Edit
The process:
Loop through the Input recordset.
Split the Description into words.
Check if the word exist in Dictionary and add or
increment.
Add the Keys (words) and Values (count) of the aforementioned
Dictionary to the Output table.
To achieve this two helper functions have been set up:
One loops through the description recordset and returns a
Dictionary object filled with unique words as Keys and their
count as Values.
The other takes the above Dictionaryobject and adds it to the Output table.
You need to change [TABLE] to the name of your Input and Output tables.
Option Explicit
Sub WordsFrequency()
On Error GoTo ErrTrap
Dim rs As DAO.Recordset
Set rs = CurrentDb().OpenRecordset("SELECT Description FROM [TABLE] WHERE Description Is Not Null;", dbOpenSnapshot)
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
If AddDictionaryToTable(ToDictionary(rs)) Then
MsgBox "Completed successfully.", vbInformation
End If
Leave:
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
' Returns Scripting.Dictionary object
Private Function ToDictionary(rs As DAO.Recordset) As Object
Dim d As Object 'Dictionary
Dim v As Variant 'Words
Dim w As String 'Word
Dim i As Long, ii As Long 'Loops
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To rs.RecordCount
v = Split(rs![Description], " ")
For ii = LBound(v) To UBound(v)
w = Trim(v(ii))
If Not d.Exists(w) Then d(w) = 1 Else d(w) = d(w) + 1
Next
rs.MoveNext
Next
Set ToDictionary = d
End Function
' Adds Dictionary object to table
Private Function AddDictionaryToTable(objDict As Object) As Boolean
On Error GoTo ErrTrap
Dim rs As DAO.Recordset
Dim n As Variant
Set rs = CurrentDb().OpenRecordset("[TABLE]")
With rs
For Each n In objDict.Keys
.AddNew
.Fields("Words").Value = n
.Fields("Counts").Value = objDict(n)
.Update
Next
End With
'all good
AddDictionaryToTable = True
Leave:
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Function
ErrTrap:
MsgBox Err.Description, vbCritical
Resume Leave
End Function
I have the following code in Access VBA.
Public Sub CalculateVol()
Dim vol As Double
Dim rs As Recordset
Dim rs2 As Recordset
Dim iRow As Long, iField As Long
Dim strSQL As String
Dim CurveID As Long
Dim MarkRunID As Long
Dim MaxOfMarkAsofDate As Date
Dim userdate As String
DoCmd.RunSQL "DELETE * FROM HolderTable"
'Clears out the old array from the holder table.
Dim I As Integer
Dim x As Date
userdate = InputBox("Please Enter the Date (mm/dd/yyyy)")
x = userdate
Dim BucketTermAmt As Long
BucketTermAmt = InputBox("Please Enter the Term Amount")
For I = 0 To 76
MaxOfMarkAsofDate = x - I
strSQL = "SELECT * FROM VolatilityOutput WHERE CurveID=" & Forms!Volatility.cboCurve.Value & " AND MaxOfMarkAsofDate=#" & MaxOfMarkAsofDate & "# ORDER BY MaxOfMarkasOfDate, MaturityDate"
Set rs = CurrentDb.OpenRecordset(strSQL, Type:=dbOpenDynaset, Options:=dbSeeChanges)
Set rs2 = CurrentDb.OpenRecordset("HolderTable")
If rs.RecordCount <> 0 Then
rs.MoveFirst
rs.MoveLast
Dim BucketTermUnit As String
Dim BucketDate As Date
Dim MarkAsOfDate As Date
Dim InterpRate As Double
Dim b As String
b = BucketTermAmt
BucketTermUnit = Forms!Volatility.cboDate.Value
BucketDate = DateAdd(BucketTermUnit, b, MaxOfMarkAsofDate)
InterpRate = CurveInterpolateRecordset(rs, BucketDate)
rs2.AddNew
rs2("BucketDate") = BucketDate
rs2("InterpRate") = InterpRate
rs2.Update
End If
Next I
vol = EWMA(0.94)
Forms!Volatility!txtVol = vol
Debug.Print vol
End Sub
The basic idea is that the user inputs a date for MaxofMarkAsofDate. The code then finds that instance of MarkAsofDate in the table VolatilityOutput, and uses it as a reference point to calculate InterpRate. It stores this number in the HolderTable. Then it loops the same procedure, except using one day previous to the user-inputted MarkAsofDate, and then one day previous to that, and so on for a total of 76 times.
The first part works fine but the loop is giving me trouble. If it doesn't find the user-inputted date in the table, it'll just skip it, but still count it as a loop. So while I want 76 data points, I might only end up with 56, for example, if it skips 20 dates. So I want to either stop it from skipping, or just keep looping until HolderTable has a total of 76 numbers in it. How do I do this?
Sounds like you want a while loop since the for loop as written will always go the same number of times. Looks like you might need a second counter to increment your date.
while count < 76
'get rs here
if rs.RecordCount <> 0 Then
'do everything else
count = count + 1
end if
dateCounter = dateCounter + 1
loop
Ok so i have a complex reason field from one of our logging servers, and i need to break it down to make some sense, problem is the format changes depending on the status.
I managed to find some strings that i can compare the the reason to to get some sense out of it, but I want to distill it down to one reason code.
I scratched my head a bit and got it down to 7 reasons with different criterion, put the criteria in a table and came up with some vb code to do the comparison.
Problem is its dead slow, and half the reporting relies on the Reason code. The basic VBA function is below, This basically loads the criteria into an array and then compares the value against the array to return the ID.
Function Reason_code(LongReason As String) As Integer
Dim NoReason As Integer
Dim I As Integer
Dim J As Integer
Dim x As Boolean
NoReason = recordCount("RejReason") - 1
Dim conExpr() As String
ReDim conExpr(NoReason)
For I = 0 To (NoReason - 1)
conExpr(I) = GetVal("Criterior", "RejReason", "id", CStr(I + 1))
Next I
For J = 0 To (NoReason - 1)
x = LongReason Like conExpr(J)
If x = True Then
GoTo OutOfLoop
End If
Next J
OutOfLoop:
Reason_code = J + 1
End Function
I have used similar in VB before and it tends to be quite fast, so i am reconing that my GetVal function is the problem, but my VBA is rusty and my SQL is pretty non existent, so any help would be appreciated. I tried LSQL and SQL2 as one line but VBA doesnt like it.
Function GetVal(FieldNm As String, TableNm As String, IndexField As String, IndexNo As String) As String
Dim db As Database
Dim Lrs As DAO.Recordset
Dim LSQL As String
Dim LGST As String
Dim SQL2 As String
'Open connection to current Access database
Set db = CurrentDb()
'Create SQL statement to retrieve value from GST table
LSQL = CStr("SELECT " + FieldNm + " FROM " + TableNm)
SQL2 = CStr(LSQL + " WHERE " + IndexField + " = " + IndexNo)
Set Lrs = db.OpenRecordset(SQL2, dbOpenDynaset, dbReadOnly)
'Retrieve value if data is found
If Lrs.EOF = False Then
LGST = Lrs(0)
Else
LGST = "Item Not found"
End If
Lrs.Close
Set Lrs = Nothing
GetVal = LGST
End Function
Thanks in advance,
I Scratched my head for a bit and worked out i could speed it up by doing the read and compare at the same time, its not lightning, but its better
Function ReasonCode(LongReason As String) As String
Dim cdb As Database
Dim rs As DAO.Recordset
Dim RejRea()
Dim NoReason As Integer
Dim result As Boolean
Dim i As Integer
Set cdb = CurrentDb()
Set rs = cdb.OpenRecordset("RejReason", dbOpenDynaset, dbReadOnly)
rs.MoveLast
rs.MoveFirst
NoReason = rs.recordCount - 1
RejRea() = rs.GetRows(rs.recordCount)
For i = 0 To NoReason
result = LongReason Like CStr(RejRea(2, i))
If result = True Then
ReasonCode = CStr(RejRea(1, i))
GoTo outloop
End If
Next i
If ReasonCode = "" Then ReasonCode = "Not Found"
outloop:
Set rs = Nothing
Set cdb = Nothing
End Function
Still not sure its the best way to do it, but in the abscence of any other suggestions it will do for now.
Anybody have some VBA code that will store a byte array into a MySQL blob column?
Here is some code. Requires a reference to Microsoft Active Data Objects 2.x Library. It uses the OLE DB provider for MySQL (Might need to install that on the client machine).
Sub StoreBLOB(data() As Byte, key As Double)
'stores the BLOB byte array into the row identified by the key
'requires reference to Microsoft Active Data Objects 2.x Library
On Error GoTo handler:
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim conStr As String
Dim strSQL As String
'have it return only the record you want to store your blob
strSQL = strSQL & "SELECT * FROM YOURTABLE WHERE KEY = " & key
'setup connection
conStr = conStr & "Provider=MySQLProv;"
conStr = conStr & "Data Source=mydb;"
conStr = conStr & "User Id=myUsername;"
conStr = conStr & "Password=myPassword;"
con.ConnectionString = conStr
con.Open
rs.Open strSQL, con, adOpenDynamic, adLockOptimistic
If rs.RecordCount > 1 Then
Err.Raise 1001, "StoreBLOB", "Too many records returned from dataset. Check to make sure you have the right key value"
Else
Err.Raise 1002, "StoreBLOB", "No Records found that match the key"
End If
rs.Fields("BLOBFIELDNAME").Value = data
rs.Update 'store the contents to the database
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Exit Sub
handler:
Err.Raise 1003, "StoreBLOB", "Unexpected Error in StoreBLOB. Check that server is running"
End Sub
Assuming you are using ADO to access mysql, there's a KB article on the subject.
I have some code, I replicated the mysql_real_escape_string_quote C function in VBA so that one can escape the necessary characters and build your SQL as you would for regular text:
Function mysql_real_escape_string_quote(toStr() As Byte, fromStr() As Byte, length As Long, quote As String) As Long
mysql_real_escape_string_quote = 0
Dim CharMap() As Byte: CharMap = StrConv(String(256, 0), vbFromUnicode)
CharMap(0) = Asc("0"): CharMap(39) = Asc("'"): CharMap(34) = Asc(""""): CharMap(8) = Asc("b"): CharMap(10) = Asc("n"): CharMap(13) = Asc("r"):
CharMap(9) = Asc("t"): CharMap(26) = Asc("z"): CharMap(92) = Asc("\"): CharMap(37) = Asc("%"): CharMap(95) = Asc("_"):
Dim i As Long: Dim n As Long: n = 0
If length > UBound(fromStr) + 1 Then Exit Function
For i = 0 To length - 1 '---count escapable chars before redim---
n = n + 1
If CharMap(fromStr(i)) <> 0 Then n = n + 1
Next i
ReDim toStr(n - 1) As Byte
n = 0
For i = 0 To length - 1 '---test chars---
If CharMap(fromStr(i)) = 0 Then
toStr(n) = fromStr(i)
Else '---escape char---
toStr(n) = Asc(quote): n = n + 1
toStr(n) = CharMap(fromStr(i))
End If
n = n + 1
Next i
mysql_real_escape_string_quote = n
End Function
Function mysql_real_escape_string(InputString As String) As String
mysql_real_escape_string = ""
Dim toStr() As Byte: Dim fromStr() As Byte
fromStr = StrToChar(InputString)
If mysql_real_escape_string_quote(toStr, fromStr, UBound(fromStr) + 1, "\") = 0 Then Exit Function
mysql_real_escape_string = StrConv(toStr(), vbUnicode)
End Function
Function StrToChar(str As String) As Byte()
Dim ans() As Byte
ans = StrConv(str, vbFromUnicode)
ReDim Preserve ans(Len(str)) As Byte
ans(Len(str)) = 0
StrToChar = ans
End Function
Sub testit()
Dim toStr() As Byte: Dim fromStr() As Byte
fromStr = StrToChar("hello world's")
MsgBox (mysql_real_escape_string_quote(toStr, fromStr, UBound(fromStr) + 1, "\"))
MsgBox (mysql_real_escape_string("hello world's"))
For i = 0 To UBound(toStr)
Debug.Print i & " " & toStr(i)
Next i
End Sub
It's been optimized for large amounts of data without a ridiculous amount of conditionals (ifs).