I'm trying to count the number of non-empty cells in an Excel spreadsheet from MS-Access VBA.
The idea is that I click a button on a form in MS-Access and the number of non-empty cells are stored as string.
The Excel workbook file is called "MattExcelFile.xls", the sheet within that workbook is called "Sheet1" and the range I want to use Excel's COUNTA function on is "C1:C500".
Here's the code I've pieced together so far:
Option Compare Database
Sub ImportDataFromRange()
Dim xlFilePath As String
Dim rowVariable As String
xlFilePath = "C:\Users\Matt\Desktop\MattExcelFile.xls"
rowVariable = Excel.Application.WorksheetFunction.CountA(Workbooks(xlFilePath).Sheets("Sheet1").Range("C1:C500"))
Debug.Print rowVariable
End Sub
Private Sub Command0_Click()
ImportDataFromRange
End Sub
And here's the error message I receive when running this code, highlighting the rowVariable = ... line:
Run-time error '9':
Subscript out of range
I am not sure if you set appropriate references therefore here is complete code for you with some comments inside.
Sub test()
Dim rowVariable As String '<--why string?
'1st
Dim xlFilePath
xlFilePath ="C:\Users\Matt\Desktop\MattExcelFile.xls"
'2nd- set refernces
Dim EXL As Object
Set EXL = CreateObject("Excel.Application")
'3rd open worksheet- required
With EXL
.Workbooks.Open xlFilePath
'4th count using WF- set appropriate reference to workbook
'be careful about sheet name- give error '9'
Dim tmpName() As String
tmpName = Split(xlFilePath, "\")
rowVariable = .WorksheetFunction.CountA(.Workbooks(tmpName(UBound(tmpName))).Sheets("Arkusz1").Range("A2:A10"))
'control of value
Debug.Print rowVariable
End With
'5th-close everything and clean
EXL.Quit
Set EXL = Nothing
End Sub
Related
I am trying to make a module to pass a single result of a query into a Combobox to be populated/displayed immediately on Form_Load event, but I keep getting the following error: Run-time error '2465' "Microsoft Access can't find the field 'MyCombo' referred to in your expression"
Query result is tested and returning the proper value. the problem is in the reference call to the MyCombo combobox.
This is my code below:
Public Function getSetRefNo() As String
Dim rs1 As DAO.Recordset
Dim currentformName As String
currentformName = Screen.ActiveForm.Name
Dim docidrefnoquery As String
Dim dociddefaultvalue As String
Set rs1 = CurrentDb.OpenRecordset("SELECT DISTINCT ColA FROM TblA WHERE ColC = " & Forms(currentformName)![Combo25])
Do Until rs1.EOF = True
docidrefnoquery = rs1(0)
rs1.MoveNext
Loop
rs1.Close
Set rs1 = Nothing
dociddefaultvalue = DLookup("RefNo", docidrefnoquery) 'RefNo here is the target column in the Query
Forms(currentformName)![MyCombo] = dociddefaultvalue 'MyCombo here is the Combobox Name
Debug.Print docidrefnoquery & " - " & dociddefaultvalue
End Function
on the targeted form, I use this code:
Private Sub Form_Load()
Call getSetRefNo
End Sub
after opening the targeted form, I receive the above mentioned error. I don't know what's wrong I tried to trace everything and it seems to be fine, I used the same chunk of codes in other places and worked fine. don't know what's wrong here to be honest. I would be grateful if you could help me elaborate what's going on.
I had to alter the form_load event like the following:
Private Sub Form_Load()
Me.TimerInterval = 30
End Sub
Private Sub Form_Timer()
Me.TimerInterval = 0
Call getSetRefNo
End Sub
Silly question but I got lost.
In a VBA function I've some text which contains a string representing a listbox control name (ctrlName is the variable containing the control name).
VarText should give back the value of the selected (row/column) from listbox (error occurred here).
Function getString_email(..)
Dim ctrlName As String
Dim getString_email as String
Dim sBody as String
Dim ctl As Control
Dim frm As Form
...
...
sBody = RS("Body")
ctrlName = Mid(sBody, StartVar, EndVar - StartVar)
Set frm = Forms("frmCatalogue")
VarText = frm.Controls(ctrlName)
Set frm = Nothing
...
...
getString_email = Replace(sBody, ctrlName, VarText)
...
error: Run-time error 2465. can't find the field referred to in your expression.
Any help will be great!
Happy Anniversary and all the best for this community
I am trying to learn the use of DoCmd.TransferSpreadsheet to export queries and charts to Excel
In my Database, I have two forms to export in each one a query to Excel and create a Chart
In each Form, the user selects a value in a textbox and an image is displayed on the Form
In Form frm_createxlstacked, the user picks two dates and click a command button to export the query to Excel and creates an xlClustered Chart. This VBA code works fine.
This is VBA code for createxlstacked
Private Sub cmbexpqry_stacked_Click()
Dim wb As Object
Dim xl As Object
Dim sExcelWB As String
Dim ws As Worksheet
Dim r As Range
Dim ch As Object ''Excel.Chart
Dim mychart As ChartObject
Dim myMax, myMin As Double
Dim qry_createxlstacked As Object
Dim fullPhotoPath As String
If IsNull(Me.cbxclstacked.Value) Then Exit Sub
Dim wb As Object, xl As Object, ch As Object, mychart As ChartObject
Dim fullPhotoPath As String
fullPhotoPath = Add_PlotMap(Form_frm_createxlstacked.cbxclstacked.Value)
Set xl = CreateObject("excel.application")
On Error Resume Next
Kill TrailingSlash(CurrentProject.Path) & Form_frm_createxlstacked.cbxxlstacked.Value & "qry_createxlstacked.xlsx"
Err.Clear
On Error GoTo 0
sExcelWB = TrailingSlash(CurrentProject.Path) & "qry_createxlstacked.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_createxlstacked.xlsx", sExcelWB, True
Set wb = xl.Workbooks.Open(sExcelWB)
Set ws = wb.Sheets("qry_createxlstacked.xlsx")
Set ch = ws.Shapes.AddChart.Chart
Set mychart = ws.ChartObjects("Chart 1")
ws.Shapes.AddPicture fullPhotoPath, msoFalse, msoCTrue, r.Left, r.Top, 500, 250
With ch
.ChartType = xlColumnClustered
.SeriesCollection(2).AxisGroup = 2
.SeriesCollection(2).ChartType = xlLineMarkers
.ChartGroups(1).GapWidth = 69
.ChartArea.Height = 250
.ChartArea.Width = 550
End with
wb.Save
xl.Visible = True
xl.UserControl = True
Set ws = Nothing
Set wb = Nothing
End Sub
In Form frm_creategannt, the user picks two dates and click a command button to export query to Excel and creates an xlClustered Chart, but, VBA displays:
Run-time error '3011'. The Microsoft Office Access database engine could not find the object 'qry_creategantt.xlsx'. Make sure that the object exists and that you...
This is VBA code
Private Sub cmbexpqry_gantt_Click()
If IsNull(Me.cmbexpqry_gantt) Then Exit Sub
Dim wb As Object
Dim xl As Object
Dim sExcelWB As String
Dim ws As Worksheet
Dim r As Range
Dim ch As Object ''Excel.Chart
Dim mychart As ChartObject
Dim qry_creategantt As Object
Dim fullPhotoPath As String
fullPhotoPath = Add_PlotMap(Form_frm_creategantt.cbxcreategantt.Value)
Set xl = CreateObject("excel.application")
On Error Resume Next
Kill TrailingSlash(CurrentProject.Path) & Form_frm_creategantt.cbxcreategantt.Value & "qry_creategantt.xlsx"
Err.Clear
On Error GoTo 0
sExcelWB = TrailingSlash(CurrentProject.Path) & "qry_creategantt.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_creategantt.xlsx", sExcelWB, True
Set wb = xl.Workbooks.Open(sExcelWB)
Set ws = wb.Sheets("qry_creategantt.xlsx")
Set ch = ws.Shapes.AddChart.Chart
Set mychart = ws.ChartObjects("Chart 1")
ws.Shapes.AddPicture fullPhotoPath, msoFalse, msoCTrue, r.Left, r.Top, 500, 250
With ch
.ChartType = xlBarStacked
End With
wb.Save
xl.Visible = True
xl.UserControl = True
Set ws = Nothing
Set wb = Nothing
End Sub
The error is '3011' occurs in this line:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, qry_creargantt.xlsx", sExcelWB, True
I compared one by one each line of codes.
Also, I checked the Queries for each form.
I need to fix Run-time error '3011' to start testing VBA code to create Gantt Chart
In my opinion, I found no error, but I am stuck
I appreciate your reply, suggestion and effort in code with error.
If the error is occuring on the DoCmd.TransferSpreadsheet line as you indicate, then the error is very clear.
You have told Microsoft Access to run the query named qry_creategantt.xlsx (in order to export that data to Excel) and that query does not exist in your database.
Check the spelling of the Query in the Queries list, and in your code. In your question above, where you restate that line of code as where the error occurs, you spelled the query name differently: qry_creargantt.xlsx. Which spelling is correct? That may be your problem.
It's not possible to call a query ".anything" the . is an illegal character in an access query name.
So carefully check the name of your query you are referring to. Because it isn't qry_creategantt.xlsx
I just starting with access and cant make things work...
trying to make simple sub that opens excell sheet and compares some values with table in access.
I am using this link as a reference:
http://www.utteraccess.com/wiki/index.php/Recordsets_for_Beginners
Private Sub Command2_Click()
Dim wb As Workbook
Set wb = openXLS
If Not wb Is Nothing Then
Dim rcs As DAO.Recordset
Dim db As Database
Set db = CurrentDb
Set rcs = db.OpenRecordset(TABLE_PRODUCTS)
Dim itemNo As String
For i = 1 To tools.LRow(wb.Sheets("Sheet1"), "A")
itemNo = wb.Sheets("Sheet1").Cells(i, "A").Value
rcs.FindFirst "ItemNo = " & itemNo 'error here, runtime error 3251
'operation is not supported for this type of object
If rcs.NoMatch = True Then
MsgBox "nomatch"
Else
MsgBox "OK"
End If
Next i
wb.Close
rcs.Close
Set wb = Nothing
Set rcs = Nothing
End If
End Sub
openXLS is a function that opens and returns workbook.
LRow returns last row in the column
i get runtime error 3251 operation is not supported for this type of object (marked in the coments)
You can't use FindFirst with table type recordsets. You will need to explicitly specify a dynaset recordset:-
Set rcs = db.OpenRecordset(TABLE_PRODUCTS, dbOpenDynaset)
You should do like this because i think you are not getting any records in recordset
if not rcs.EOF then
rcs.FindFirst "ItemNo = " & itemNo 'error here, runtime error 3251
'operation is not supported for this type of object
If rcs.NoMatch = True Then
MsgBox "nomatch"
Else
MsgBox "OK"
End If
end if
Update
Can you try using seek method instead of findfirst
rcs.Seek "=", itemNo
Update 2
First set index of your primary id like
rcs.index= "Id" -- do this after you create DAO recordset
Then try this
rcs.Seek Comparison:="=", itemNo:=itemNo
Info: Excel 2010
Notes: The code works exactly how I need, I am now wanting to automate it a little
I recently came across this code, it's for a custom function, however I can not create a button for it (like a macro), I would like to convert some of this code, however I don't know what to do or how to go about it. I want to have a shortcut/button on my ribbon.
https://stackoverflow.com/a/17337453/2337102
Function listUnique(rng As Range) As Variant
Dim row As Range
Dim elements() As String
Dim elementSize As Integer
Dim newElement As Boolean
Dim i As Integer
Dim distance As Integer
Dim result As String
elementSize = 0
newElement = True
For Each row In rng.Rows
If row.Value <> "" Then
newElement = True
For i = 1 To elementSize Step 1
If elements(i - 1) = row.Value Then
newElement = False
End If
Next i
If newElement Then
elementSize = elementSize + 1
ReDim Preserve elements(elementSize - 1)
elements(elementSize - 1) = row.Value
End If
End If
Next
distance = Range(Application.Caller.Address).row - rng.row
If distance < elementSize Then
result = elements(distance)
listUnique = result
Else
listUnique = ""
End If
End Function
Results with the ability to:
Just enter =listUnique(range) to a cell. The only parameter is range
that is an ordinary Excel range. For example: A$1:A$28 or H$8:H$30.
I would like the following:
Create a macro button with an a popup Inputbox to ask for a range.
Usage:
1) I am in the cell where I require the list to begin (BA9)
2) I click the custom module/macro button & popup box asks me the range (G$8:G$10000)
3) The result then autofills in column (BA)
Lastly, can the code be amended so that the restriction of "The first cell where you call the function must be in the same row where the range starts." be removed so that I can use a reference from another sheet within the same workbook.
I apologise if I should have gone direct to the coder, the thread that it was in is old & I thought given the amount of change I'm asking for it may be better suited in its own question.
Thank you in advance.
First approach: (you can use RemoveDuplicates method instead function listUnique)
Just assign this Sub to your custom button:
Sub testRemoveDuplicates()
Dim targetRange As Range
Dim actCell As Range
Dim res As Variant
Set actCell = ActiveCell
On Error Resume Next
Set targetRange = Application.InputBox("Please highlight the cell for TARGET", Type:=8)
On Error GoTo 0
If targetRange Is Nothing Then
MsgBox "User has pressed cancel"
Exit Sub
End If
targetRange.Copy
actCell.PasteSpecial xlPasteValues
actCell.RemoveDuplicates Columns:=1, Header:=xlNo
Application.CutCopyMode = False
End Sub
Second approach: (if you'd like to use function listUnique)
Here is another listUnique function. You can get list of unique elements usign Dictionary object (it is better suited for your purposes):
Function listUnique(rng As Range) As Variant
Dim row As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each row In rng.Rows
If row.Value <> "" Then
dict.Add row.Value, row.Value
End If
Next
Dim res As Variant
ReDim res(1 To dict.Count)
res = dict.Items
Set dict = Nothing
listUnique = Application.Transpose(res)
End Function
then you can call it using following Sub (you can assign it to custom button):
Sub test()
Dim targetRange As Range
Dim actCell As Range
Dim res As Variant
Set actCell = ActiveCell
On Error Resume Next
Set targetRange = Application.InputBox("Please highlight the cell for TARGET", Type:=8)
On Error GoTo 0
If targetRange Is Nothing Then
MsgBox "User has pressed cancel"
Exit Sub
End If
res = listUnique(targetRange)
actCell.Resize(UBound(res)) = res
End Sub
Note: if you're going to call this listUnique function direct from worksheet (as UDF function), you should select destination range (in example D10:D20), with selected range enter formula =listUnique(A1:A10) in formula bar, and press CTRL+SHIFT+ENTER to evaluate it.