When I run my code, the program cannot find the reference to my field. How can I fix this?
The field that has no reference is "Me![SetupMenuID]."
Dim con As Object
Dim rs As Object
Dim stSql As String
On Error GoTo SetupButtonClick_Err
' Find the item in the Switchboard Items table
' that corresponds to the button that was clicked.
Set con = Application.CurrentProject.Connection
Set rs = CreateObject("ADODB.Recordset")
stSql = "SELECT * FROM [Setup Sheet Items] "
stSql = stSql & "WHERE [SetupMenuID]=" & Me![SetupMenuID] & " AND [SetupItemNumber]=" & numBtn
rs.Open stSql, con, 1 ' 1 = adOpenKeyset
I'm using VBA and I have an error while running the attached code, it says Type mismatch.
Can someone help me where to find the mistake?
please
Private Sub List1_DblClick()
Dim val As String
Dim val2 As String
Dim i As Integer
Dim rs As ADODB.Recordset
Set GSBMconn = New ADODB.Connection
'Set rs = New ADODB.Recordset
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
val = List1.List(i)
Debug.Print (val)
Set rs = Grid.DataSource
rs.AddNew
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=cmd\cmd.mdb;Persist Security Info=False;Jet OLEDB:Database Password="
With Adodc1
.RecordSource = "SELECT *" & _
"FROM StockLevel3 " & _
"WHERE ItemName = '" & val & "'; "
End With
Set Grid.DataSource = Adodc1
Adodc1.Refresh
End If
Next
End Sub
I have 31 text boxes that get populated with ADO from a Calendar Table as per below function:
Private Function FillDates()
Dim cnn As ADODB.Connection
Dim ssql As String
Dim rst As ADODB.Recordset
Set cnn = CurrentProject.Connection
Dim i As Integer
Dim Records As Integer
ssql = "SELECT RoomAvailabilityId, Availability FROM RoomAvailability WHERE Month(AvailabilityDate)=Month(Now()) AND RoomTypesId=1"
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open ssql, cnn
Records = rst.RecordCount
For i = 1 To Records
Me("idtext" & i).Value = rst.Fields!RoomAvailabilityId
Me("Text" & i).Value = rst.Fields!Availability
rst.MoveNext
Next i
rst.Close
Set rst = Nothing
End Function
This is a simplified version of the actual code. The actual code hides the text boxes when a month is made up of 30 days or 29/28 days.
So I have 2 values now stored in my grid made up of the above text boxes.
I now want to update my table field called Availability (Number - Long Integer Datatype) with a button click and I am not able to touch base with this.
Could you please suggest how? This is my starting non working code:
Private Sub cmdUpdatetxt_Click()
Dim cn As ADODB.Connection '* Connection String
Dim oCm As ADODB.Command '* Command Object
Dim iRecAffected As Integer
Set cn = CurrentProject.Connection
Dim i As Integer
For i = 1 To 31
AvailableRooms = Me("txt" & i).Value
AvailableRoomsId = Me("idtext" & i).Value
Next i
Set oCm = New ADODB.Command
oCm.ActiveConnection = cn
oCm.CommandText = "Update RoomAvailability Set Availability ='" & AvailableRooms & "' WHERE RoomAvailabilityId = '" & AvailableRoomsId & "' AND Month(RoomAvailability.AvailabilityDate) = '" & cboMonthYear.Value & "' "
oCm.Execute iRecAffected
If iRecAffected = 0 Then
MsgBox "Nessun Utente Inserito"
End If
If cn.State <> adStateClosed Then
cn.Close
If Not oCm Is Nothing Then Set oCm = Nothing
If Not cn Is Nothing Then Set cn = Nothing
End If
End Sub
Thank you very much in advance
As per Nathan_Sav suggestion, this is the working code:
Private Sub cmdUpdatetxt_Click()
On Error GoTo ErrorTrap
Dim i As Integer
For i = 1 To 31
Dim cn As ADODB.Connection '* Connection String
Dim oCm As ADODB.Command '* Command Object
Dim iRecAffected As Integer
Set cn = CurrentProject.Connection
AvailableRooms = Me("txt" & i).Value
AvailableRoomsId = Me("idtext" & i).Value
Set oCm = New ADODB.Command
oCm.ActiveConnection = cn
oCm.CommandText = "Update RoomAvailability Set Availability =" & AvailableRooms & " WHERE RoomAvailabilityId = " & AvailableRoomsId & " AND Month(RoomAvailability.AvailabilityDate) = '" & cboMonthYear.Value & "' "
oCm.Execute iRecAffected
If iRecAffected = 0 Then
MsgBox "Nessun Utente Inserito"
End If
If cn.State <> adStateClosed Then
cn.Close
If Not oCm Is Nothing Then Set oCm = Nothing
If Not cn Is Nothing Then Set cn = Nothing
End If
Next i
Exit Sub
ErrorTrap:
MsgBox (Err.Description)
End Sub
Have a great day
OK so I have a spreadsheet that produces a reasonably large amount of records (~3500)
I have the following script that inserts them into my access db:
Sub putinDB()
Dim Cn As ADODB.Connection, Rs As ADODB.Recordset
Dim MyConn, sSQL As String
Dim Rw As Long, c As Long
Dim MyField, Result
Dim x As Integer
Dim accName As String, AccNum As String, sector As String, holding As String, holdingvalue As Double, holdingdate As Date
theend = lastRow("Holdings", 1) - 1
'Set source
MyConn = "S:\Docs\Harry\Engine Client\Engine3.accdb"
'Create query
Set r = Sheets("Holdings").Range("a2")
x = 0
Do
Application.StatusBar = "Inserting record " & x + 1 & " of " & theend
accName = r.Offset(x, 0)
AccNum = r.Offset(x, 4)
sector = r.Offset(x, 2)
holding = r.Offset(x, 1)
holdingvalue = r.Offset(x, 3)
holdingdate = r.Offset(x, 5)
sSQL = "INSERT INTO Holdings (AccName, AccNum, Sector, Holding, HoldingValue, HoldingDate)"
sSQL = sSQL & " VALUES ('" & Replace(accName, "'", "''") & "', '" & AccNum & "', '" & sector & "', '" & Replace(holding, "'", "''") & "', '" & holdingvalue & "', #" & holdingdate & "#)"
Debug.Print (sSQL)
'Create RecordSet
Set Cn = New ADODB.Connection
With Cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.CursorLocation = adUseClient
.Open MyConn
Set Rs = .Execute(sSQL)
End With
x = x + 1
Loop While r.Offset(x, 0) <> "" Or x < 15
Application.StatusBar = False
End Sub
The trouble is, is that it loops through each record one-by-one, rebuilds and executes the query each time which results in very slow execution (about 2-3 records per second on my PC)
Is there a way to have vba insert the whole range into the DB in one go without having to loop through?
Thanks
The answer you have provided should improve things slightly as you only need open the connection once, but the code is still inefficient. You really only want to write to your recordset once with all the data rather than like this. I always prefer working from the Access side to pull info from Excel as oppose to pushing into Access from Excel but I believe we can use either for this scenario.
In this case your better to use DAO over ADO and work with a Transacation, essentially you still loop over the recordset but the actual act of writing the data does not happen until you Commit at the end so it's much faster.
This is a very basic example from the Access side for you to try:
Private Sub TestTrans()
Dim wksp As DAO.Workspace
Dim rs As DAO.Recordset
Set wksp = DBEngine.Workspaces(0) 'The current database
wksp.BeginTrans 'Start the transaction buffer
Set rs = CurrentDb.OpenRecordset("Table1", dbOpenDynaset)
Do 'Begin your loop here
With rs
.AddNew
!Field = "Sample Data"
.Update
End With
Loop 'End it here
wksp.CommitTrans 'Commit the transaction to dataset
End Sub
OK, silly me. After a bit of tinkering it turns out that putting the
Set Cn = New ADODB.Connection
With Cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.CursorLocation = adUseClient
.Open MyConn
End With
bit outside the loop makes it far quicker.
I'm trying to create a dropdown that upon changing the selection from the list of options will run a query that will insert the query results into the page. Here's what I have thus far:
Sub DropDown1_Change()
Dim dbConnect As String
Dim leagueCode As String
Dim leagueList As Range
Dim leagueVal As String
Dim TeamData As String
Set leagueList = Worksheets("Menu Choices").Range("A5:A10")
Set leagueVal = Worksheets("Menu Choices").Cell("B1").Value
leagueCode = Application.WorksheetFunction.Index(leagueList, leagueVal)
TeamData = "SELECT DISTINCT(Teams.teamID), name FROM Teams WHERE lgID = '" & leagueCode & "' & ORDER BY name ASC"
With Worksheets("Menu Choices").QueryTables.Add(Connection:=dbConnect, Destination:=Worksheets("Menu Choices").Range("D5"))
.CommandText = TeamData
.Name = "Team List Query"
.Refresh BackgroundQuery:=False
End With
End Sub
Anywho have any suggestions to get it working? Thanks in advance!
I was able to resolve the issue using similar code to the following:
Sub createTeamList()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SQL As String
Dim inc As Integer
Dim topCell As Range
Dim leagueID As String
Dim leagueList As Range
Dim leagueChoice As Range
Set leagueList = Worksheets("Menu Choices").Range("A4:A9")
Set leagueChoice = Worksheets("Menu Choices").Range("B1")
leagueID = Application.WorksheetFunction.Index(leagueList, leagueChoice)
Set topCell = Worksheets("Menu Choices").Range("D4")
With topCell
Range(.Offset(1, 0), .Offset(0, 1).End(xlDown)).ClearContents
End With
With cn
.ConnectionString = "Data Source=" & ThisWorkbook.Path & "\lahman_57.mdb"
.Provider = "Microsoft Jet 4.0 OLE DB Provider"
.Open
End With
inc = 0
SQL = "SELECT teamID, name " _
& "FROM Teams " _
& "WHERE lgID = '" & leagueID & "' " _
& "GROUP BY teamID, name " _
& "ORDER BY name "
rs.Open SQL, cn
With rs
Do Until .EOF
topCell.Offset(inc, 0) = .Fields("teamID")
topCell.Offset(inc, 1) = .Fields("name")
inc = inc + 1
.MoveNext
Loop
End With
rs.Close
cn.Close
End Sub