I am new to coding in Access VBA. I am trying to run the following code to extract the selected records from an Access Table and export them to excel but it keeps on showing me the 'Subscript out of range' error.This is the part of the code where I am getting an error. Any help would be appreciated. Thank you
Set db = CurrentDb()
Set rec = db.OpenRecordset("Tablename", dbOpenDynaset)
Dim k As Integer
Dim n() As Variant
Dim m() As Variant
Dim p() As Variant
Dim q() As Variant
Dim size As Integer
k = 10
i = 1
If Not rec.EOF Then
rec.MoveFirst
rec.FindFirst ("Variable1 = '" & Me.Variable1.Value & "' AND Variable2 = " & Me.Variable2.Value & " AND Variable3 = '" & Me.Variable3.Value & "'")
size = DCount("[Field4]", "Tablename", "Variable1 = '" & Me.Variable1.Value & "' AND Variable2 = " & Me.Variable2.Value & " AND Variable3 = '" & Me.Variable3.Value & "'")
ReDim n(size) As String
ReDim m(size) As String
ReDim p(size) As String
ReDim q(size) As String
Do Until rec.EOF
If Not IsNull(rec.Fields("Field4")) Then
n(i) = rec.Fields("Field4")
WKS.Cells((k), 1) = n(i)
End If
If Not IsNull(rec.Fields("Field3")) Then
m(i) = rec.Fields("Field3")
WKS.Cells((k), 2) = m(i)
End If
If Not IsNull(rec.Fields("Field2")) Then
p(i) = rec.Fields("Field2")
WKS.Cells((k), 3) = p(i)
End If
If Not IsNull(rec.Fields("Field1")) Then
q(i) = rec.Fields("Field1")
WKS.Cells((k), 4) = q(i)
End If
rec.MoveNext
k = k + 1
i = i + 1
Loop
End If
Set rec = Nothing
Related
I am using an excel file that has some code that will compile data into a .txt file when a button is clicked. I am getting an error "Bad name or number" when the code is run. Here is a screenshot where I am getting the error. THis is my first time using this so I don't really know what the issue is. Thank you!
enter image description here
This code should create a .txt file that I can use to create a map on mapchart.net
Here is the full code:
Sub export_Click()
Set fs = CreateObject("Scripting.FileSystemObject")
Dim pathname As String
Dim iRet As Integer
Dim strMsg As String
Dim dict As Object, key, val
Set dict = CreateObject("Scripting.Dictionary")
Dim wsName As String
wsName = Replace(ActiveSheet.Name, " ", "_")
Dim rgch As String
Dim RandomString As String
rgch = "abcdefghijklmnopqrstuvwxyz"
rgch = rgch & UCase(rgch) & "0123456789"
Dim i As Long
For i = 1 To 8
RandomString = RandomString & Mid$(rgch, Int(Rnd() * Len(rgch) + 1), 1)
Next
pathname = ActiveWorkbook.Path & "\mapchartSave_" & wsName & "_" & RandomString & ".txt"
Debug.Print (findTotalRows())
Set a = fs.CreateTextFile(pathname, True)
Dim outp As String
Dim totalRows As String
Dim final As String
Dim cell As Range
Dim color As String
Dim countyName As String
outp = "{'groups':{'"
totalRows = findTotalRows()
'--> Loop through each cell in column E (COLOR)
For Each cell In ActiveSheet.Range("D2:D" & totalRows)
color = LCase(rgb2hex(cell))
If Not color = "#d1dbdd" Then
countyName = "'" & cell.Offset(0, -3).Value & "',"
If Not dict.Exists(color) Then
dict.Add color, countyName
Else
dict(color) = dict(color) & countyName
End If
End If
Next cell
Dim boxNo As Integer
boxNo = 0
For Each key In dict.Keys
outp = outp & key & "':{'div':'#box" & boxNo & "','label':'Label Text " & boxNo & "','paths':[" & dict(key)
outp = Left(outp, Len(outp) - 1)
outp = outp & "]},'"
boxNo = boxNo + 1
'--> Debug.Print key, dict(key)
Next key
'--> Remove the trailing comma from the output
outp = Left(outp, Len(outp) - 2)
outp = outp & "},'title':'Legend Title','borders':'#000000'}"
'--> Replace all ' with ""
final = Replace(outp, "'", """")
a.WriteLine (final)
a.Close
strMsg = "Your MapChart configuration file was saved as mapchartSave_" & wsName & "_" & RandomString & ".txt "
iRet = MsgBox(strMsg, vbOKOnly, "Success")
End Sub
Function rgb2hex(rcell) As String
Dim cellColor As String
'--> Check if cell has color from conditional formatting
Dim cfColor As String
cfColor = Cells(rcell.Row, rcell.Column).DisplayFormat.Interior.color
If cfColor = "65535" Then
cellColor = Hex(rcell.Interior.color)
Else
cellColor = Hex(cfColor)
End If
cellColor = Right("000000" & cellColor, 6)
rgb2hex = "#" & Right(cellColor, 2) & Mid(cellColor, 3, 2) & Left(cellColor, 2)
End Function
Function findTotalRows() As String
Dim N As Long
N = Cells(1, 1).End(xlDown).Row
findTotalRows = CStr(N)
End Function
Sub reset_Click()
Dim cell As Range
Dim color As String
Dim totalRows As String
totalRows = findTotalRows()
For Each cell In ActiveSheet.Range("D2:D" & totalRows)
color = LCase(rgb2hex(cell))
If Not color = "#d1dbdd" Then
cell.Interior.color = RGB(209, 219, 221)
End If
Next cell
End Sub
For example, I have some data in an excel sheet 'MySheet' as follows:
sepal
petal
5
11
4
12
3
13
I need to convert these data into a dictionary follows after calling a VBA function named dict= ex_dict () where I can access to each key like :
dict=ex_dict(A1:B4)
dict= {"sepal": [5,4,3], "petal": [11,12,13]}
Or
dict ('sepal')= [5,4,3]
Initially, I thought I have found a solution. But later I have found that given solutions are output as string but not as Dictionary object
Columns to String
Function ex_dict(ByVal rg As Range) As String
Dim rCount As Long: rCount = rg.Rows.Count
If rCount < 2 Then Exit Function
ex_dict = "{"
Dim crg As Range
Dim r As Long
For Each crg In rg.Columns
ex_dict = ex_dict & """" & crg.Cells(1).Value & """: ["
For r = 2 To rCount
ex_dict = ex_dict & crg.Cells(r).Value & ","
Next r
ex_dict = Left(ex_dict, Len(ex_dict) - 1) & "], "
Next crg
ex_dict = Left(ex_dict, Len(ex_dict) - 2) & "}"
End Function
Please, use the next function:
Function ex_dictX(rng As Range) As String
Dim dict As Object, i As Long, j As Long, arr, strIt As String
Set dict = CreateObject("Scripting.Dictionary")
arr = rng.Value2: strIt = "["
For i = 1 To UBound(arr, 2)
For j = 2 To UBound(arr)
strIt = strIt & arr(j, i) & ","
Next j
dict.Add Chr(34) & arr(1, i) & Chr(34) & ": ", left(strIt, Len(strIt) - 1) & "]"
strIt = "["
Next i
'build the string to be returned (as pseudo dictionary):
For i = 0 To dict.count - 1
strIt = strIt & dict.Keys()(i) & dict.items()(i) & ", "
Next
ex_dictX = "{" & left(strIt, Len(strIt) - 2) & "}"
End Function
It can be tested with a simple Sub:
Sub tesTex_dict()
Debug.Print ex_dict(Range("A1:B4"))
End Sub
or call it as UDF (User Defined Function) from a cell as:
=ex_dict(A1:B4)
Edited:
Please, test the next version which returns a Scripting.Dictionary:
Function ex_dictD(rng As Range) As Object
Dim dict As Object, i As Long, j As Long, arr, strIt As String
Set dict = CreateObject("Scripting.Dictionary")
arr = rng.Value2: strIt = "["
For i = 1 To UBound(arr, 2)
For j = 2 To UBound(arr)
strIt = strIt & arr(j, i) & ","
Next j
dict.Add Chr(34) & arr(1, i) & Chr(34), left(strIt, Len(strIt) - 1) & "]"
strIt = "["
Next i
Set ex_dictD = dict
End Function
It can be tested in a Sub like the following one:
Sub testEx_dict()
Dim dict As Object, i As Long
Set dict = ex_dictD(Range("A1:C4"))
For i = 0 To dict.count - 1
Debug.Print dict.Keys()(i) & " = " & dict.items()(i)
Next
End Sub
Using the Dictionary Object.
Sub Example()
'Create a Dictionary object
Dim sepal As Object
Set sepal = CreateObject("Scripting.Dictionary")
'Loop through the table
Dim Cell As Range
For Each Cell In Range("A2:A5")
'Add unique entries to the dictionary
If Not sepal.exists(Cell.Value) Then
'Add cell value as the Key & the adjacent value as the Item.
sepal.Add Cell.Value, Cell.Offset(, 1).Value
End If
Next
Debug.Print sepal(4) 'returns 12
Debug.Print sepal(3) 'returns 13
End Sub
After building the dictionary, sepal.Keys returns the array [5,4,3] and sepal.Items returns the array [11,12,13].
The following function returns an array to a worksheet.
I mark an area, type my function and Ctrl+Shift+Enter to get the cells filled with data from a recordset.
But if the selected area for my CSE function is larger than the returned recordset, I receive a #N/A. And if it is smaller, no warning is indicated.
Is there an easy way to replace the #N/A with "" values, and if a range of the array function smaller than the returned array - to display a warning?
Here is my current working function that returns an array from the recordset:
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, varOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim varOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
varOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
varOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional alternative - write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = varOut
' End With
SQL = varOut
Erase varOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
If your output array is smaller than the calling range, you can just fill the unused portions of the output array with "".
If the calling range is too small, you can show a message box, or return an Excel error value, or... Depends what you want.
Example of how to do these things.
Function test()
'Get interesting content
Dim contentOut As Variant
contentOut = [{1,2;3,4}] ' or a database connection, or whatever
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
MsgBox "your range is too small."
' or return #VALUE! error
test = CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 1 To UBound(contentOut, 1)
For iCol = 1 To UBound(contentOut, 2)
varOut(iRow, iCol) = contentOut(iRow, iCol)
Next
Next
test = varOut
End Function
I would like to thank Jean very much for an answer and paste the complete code I owe it to those who helped me! I introduced only a small shift to the array so that the header and last column shows up.
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, contentOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim contentOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
contentOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
contentOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional solution: Write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = contentOut
' End With
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
'MsgBox "your range is too small."
' or return #VALUE! error
SQL = "Too small range" 'CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 0 To UBound(contentOut, 1)
For iCol = 0 To UBound(contentOut, 2)
varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol)
Next
Next
SQL = varOut
'Cleanup
Erase contentOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
in a VBA excel macro I am using, I have the following code:
For k = MinDeg To MaxDeg
OutputStr = Trim(OutputStr & "a" & Str(k) & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next k
Where "MyCoe" and "MyErr" are given numbers, and "minDeg" and "MaxDeg" are integers.
My question is:
How can I make "Str(k)" appear in the outputstr as subscript text?
If Unicode is available in your environment, another option would be to use the subscripted Unicode characters for Str(K). Making some modifications to Gary's Student code so as to get output in A1:
Option Explicit
Sub foo()
Dim K As Long
Const MinDeg As Long = 10
Const MaxDeg As Long = 13
Dim sK As String, I As Long
Const MyCoe As Long = 3
Const MyErr As Long = 5
Dim OutPutStr As String
For K = MinDeg To MaxDeg
sK = ""
For I = 1 To Len(CStr(K))
sK = sK & ChrW(832 & Mid(CStr(K), I, 1))
Next I
OutPutStr = Trim(OutPutStr & "a" & sK & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next K
Cells(1, 1) = OutPutStr
End Sub
Note that the subscripted values also appear in the formula bar.
First I run this simple mod to your code:
Sub WhatEverr()
mindeg = 10
maxdeg = 13
mycoe = 3
myerr = 5
For k = mindeg To maxdeg
outputstr = Trim(outputstr & "a" & Str(k) & " = " & _
Str(mycoe) & " ± " & _
Str(myerr) & Chr(10))
Next k
Range("A1").Value = outputstr
End Sub
to get this in A1:
Then I run:
Sub formatcell()
Dim i As Long, L As Long, rng As Range
Dim s As String
Set rng = Range("A1")
s = rng.Value
L = Len(s)
For i = 1 To L
ch = Mid(s, i, 1)
If ch = "a" Then
rng.Characters(Start:=i + 2, Length:=2).Font.Subscript = True
End If
Next i
End Sub
To apply the format:
In Excel, this type of character formatting is a property of the Range object. You do not build it into the string like you would in HTML.
I am trying to convert String of cells position into range
Dim closeAfcc As Integer
Dim restCases As Integer
Dim AFCCRange As String
Dim rng As Range
i = 2
closeAfcc = 0
restCases = 0
Do
If Sheet1.Cells(i, 6) = "Closed-AFCC" Then
closeAfcc = closeAfcc + 1
AFCCRange = AFCCRange + "sheet1!K" & i & ","
Else
restCases = restCases + 1
End If
i = i + 1
Loop Until Sheet1.Cells(i, 6) = ""
AFCCRange = Left(AFCCRange, Len(AFCCRange) - 1)
Set rng = Range(AFCCRange)
I got Error 1004
my string result is
AFCCRange= sheet1!K2,sheet1!K3,sheet1!K4,sheet1!K6,sheet1!K7,sheet1!K8,sheet1!K9,sheet1!K10,sheet1!K11,sheet1!K12
Thanks
Change this code:
AFCCRange = AFCCRange + "sheet1!K" & i & ","
To read:
AFCCRange = AFCCRange & "'sheet1'!$K$" & i & ", "
Also change:
AFCCRange = Left(AFCCRange, Len(AFCCRange) - 1)
To read:
AFCCRange = Left(AFCCRange, Len(AFCCRange) - 2)