I need to find a way to make grid in MS Access & insert new lines to it by code VBA only
exactly how excel behave.
Have you looked at continuous forms and datasheets?
It is very rarely a good idea to replicate spreadsheet behaviour in a database
Code InsertRows : insert row in between tow row
first Create A temporarilytable And then deal with this table like the main table
and the code is Work with me
and here the code :
Sub InsertRows()
On Error GoTo ErrorNu
Dim SQLP As String
Dim Con As New ADODB.Connection
Dim Conx As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Rs As New ADODB.Recordset
Dim Rsx As New ADODB.Recordset
Dim Rn As New ADODB.Recordset
Dim Rd As New ADODB.Recordset
Dim Num As Long
Dim intRows
Dim arrEmployees As Variant
Dim x As Integer, Y As Integer
Set Con = CurrentProject.Connection
Con.BeginTrans
sqlo = " select max(AutoRec)as maxa from Note_Custom "
Set Rn = Con.Execute(sqlo)
SQLP = " SELECT AutoRec, TextCOspoId, OuerM,Note"
SQLP = SQLP & " , TextBillId,NuCOspoId,dateTybe FROM Note_Custom ORDER BY AutoRec"
Rs.Open SQLP, Con, adUseClient, adOpenStatic, adCmdText
sqlo = " UPDATE Note_Custom SET TextBillId = ''"
sqlo = sqlo & " WHERE AutoRec > " & 0
Con.Execute (sqlo)
intRows = Val(Rn!maxa)
Num = 1
arrEmployees = Rs.GetRows(intRows)
Y = 0
For x = 0 To intRows - 1
If x = Val(SelTop - 1) Then
Y = 1
Rs.AddNew
Rs![AutoRec] = arrEmployees(0, x)
Rs![TextBillId] = 1
Rs.Update
End If
Rs.AddNew
Rs![AutoRec] = arrEmployees(0, x) + Y
Rs![TextCOspoId] = arrEmployees(1, x)
Rs![OuerM] = arrEmployees(2, x)
Rs![Note] = arrEmployees(3, x)
Rs![NuCOspoId] = arrEmployees(5, x)
Rs![dateTybe] = arrEmployees(6, x)
Rs![TextBillId] = 1
Rs.Update
Next x
sqlo = "DELETE * FROM Note_Custom where TextBillId = """""
Con.Execute (sqlo)
Con.CommitTrans
SelFiled = Me.SelTop
Me.Requery
sqlo = "SELECT Last(AutoRec) AS LastAuto,First(AutoRec) AS FirstAuto,Count(AutoRec) AS CountAuto FROM Note_Custom"
Set Rd = Con.Execute(sqlo)
If Me.SelTop <> AutoRec Or Rd!LastAuto <> Rd!CountAuto Then
Refix
End If
DoCmd.GoToRecord , , acGoTo, SelFiled
'Me.SelTop = SelFiled
If RecType = False Then
Forms![Ncustom]!Edite.Enabled = True
Forms![Ncustom]!Viewer1.Enabled = False
Forms![Ncustom]!DELETE.Enabled = False
End If
arrEmployees = Empty
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
Exit Sub
ErrorNu:
SelFiled = Me.SelTop
Me.Requery
Me.SelTop = SelFiled
End Sub
Related
I have adapted some code I found to extract a mySQL table and write it to a worksheet. However, it is slow for some of the larger tables(30,000+). I am trying to find a better way to import the values and avoid looping. I was hoping to be able to assign it directly to a range, but have been unsuccessful. From my research, it seems Excel is limited when it comes to mySQL. Any suggestions?
Dim password As String
Dim sqlstr As String
Dim dbTable As String
'OMIT Dim Cn statement
Dim server_Name As String
Dim user_ID As String
Dim database_Name As String
Dim lRow As Integer, lCol As Integer
'Start timer
Dim Count As Long
Dim BenchMark As Double
BenchMark = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
'OMIT Dim rs statement
Set rs = CreateObject("ADODB.Recordset") 'EBGen-Daily
server_Name = Sheet10.Range("b1").Value
database_Name = Sheet10.Range("b2").Value ' Name of database
user_ID = Sheet10.Range("b3").Value 'id user or username
password = Sheet10.Range("b4").Value 'Password
dbTable = Sheet10.Range("tbl_name").Value
sqlstr = "SELECT * FROM " & dbTable
Set cn = New ADODB.Connection
'On Error Goto ErrorHandler
cn.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver};" & _
"SERVER=" & server_Name & ";" & _
"DATABASE=" & database_Name & ";" & _
"USER=" & user_ID & ";" & _
"PASSWORD=" & password & ";" & _
"Option=16427"
rs.Open sqlstr, cn, adOpenStatic
'MsgBox cn.Execute("SELECT COUNT(*) As row_count FROM elite_advocacy;")!row_count + 1
Dim myArray()
myArray = rs.GetRows()
kolumner = UBound(myArray, 1)
rader = UBound(myArray, 2)
'Delete existing table
On Error Resume Next
Sheet2.ListObjects("tbl_data").Delete
On Error GoTo 0
'Write array to sheet <<< Slow for large datasets
For k = 0 To kolumner ' Using For loop data are displayed
Sheet2.Range("rng_s_data").Offset(0, k).Value = rs.Fields(k).Name
For r = 0 To rader
Sheet2.Range("rng_s_data").Offset(r + 1, k).Value = myArray(k, r)
Next
Next
'Write array to range <<< Failed
'Attempt 2
'Dim r1 As Range, rBase As Range
'Dim L As Long, U As Long
'Set rBase = Sheet2.Range("rng_s_data")
'L = LBound(myArray)
'U = UBound(myArray)
'r1 = rBase.Resize(1, rader - kolumner + 1)
'r1 = myArray
'Find lRow and lCol
lRow = Cells(Rows.Count, Range("rng_s_data").Column).End(xlUp).Row
lCol = Cells(Range("rng_s_data").Row, Columns.Count).End(xlToLeft).Column
'Create a table from Data
'Sheet2.ListObjects.Add(xlSrcRange, Sheet2.Range("A$5:$Z$100"), , xlYes).Name = "tbl_data"
Sheet2.ListObjects.Add(xlSrcRange, Sheet2.Range(Sheet2.Cells(Sheet2.Range("rng_s_data").Row, Sheet2.Range("rng_s_data").Column), _
Sheet2.Cells(lRow, lCol)), , xlYes).Name = "tbl_data"
Sheet2.ListObjects("tbl_data").TableStyle = "TableStyleLight1"
'Autofit Sheet
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
'End Timer
MsgBox Timer - BenchMark
Errorhandler:
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
I don't have mySQl for testing, but something like this would be a generic approach to querying any database from Excel using ADO.
Performance is optimum if you avoid any looping which involves cell-by-cell access, and do as much as you can with arrays, before transferring the final array to the worksheet in a single operation.
It's worth putting in extra effort to create re-usable pieces of code as standalone Subs or Functions - that allows your main logic to stay focused on the task at hand.
Sub Tester()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sql As String, dbTable As String, data, rngTbl As Range
Dim BenchMark As Double
BenchMark = Timer
Set cn = GetConnection()
Set rs = New ADODB.Recordset
dbTable = Sheet10.Range("tbl_name").Value
sql = "SELECT * FROM " & dbTable
rs.Open sql, cn, adOpenStatic
data = RecordSetToArray(rs) 'Includes field names
'data = RecordSetToArray(rs,False) 'False = no field names
'Delete existing table
On Error Resume Next
sheet2.ListObjects("tbl_data").Delete
On Error GoTo 0
'put the data on the worksheet
Set rngTbl = ArrayToSheetRange(data, sheet2.Range("rng_s_data"))
With sheet2.ListObjects.Add(xlSrcRange, rngTbl, , xlYes)
.Name = "tbl_data"
.TableStyle = "TableStyleLight1"
.Range.EntireColumn.AutoFit
End With
Debug.Print "Done in " & Timer - BenchMark
End Sub
'return an opened connection object
Function GetConnection() As ADODB.Connection
Dim serverNm As String, userId As String, dbNm As String, pw As String
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
serverNm = Sheet10.Range("b1").Value
dbNm = Sheet10.Range("b2").Value ' Name of database
userId = Sheet10.Range("b3").Value 'id user or username
pw = Sheet10.Range("b4").Value 'Password
cn.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver};" & _
"SERVER=" & serverNm & ";" & _
"DATABASE=" & dbNm & ";" & _
"USER=" & userId & ";" & _
"PASSWORD=" & pw & ";" & _
"Option=16427"
Set GetConnection = cn
End Function
'Create a 2-D array from a recordset
Function RecordSetToArray(rs As ADODB.Recordset, _
Optional IncludeFieldNames As Boolean = True)
Dim tmp, nC As Long, nR As Long, data, r As Long, c As Long, rowNum As Long
tmp = rs.GetRows() 'cols x rows
nC = UBound(tmp, 1) + 1 'zero-based --> 1-based
nR = UBound(tmp, 2) + 1
ReDim data(1 To nR + IIf(IncludeFieldNames, 1, 0), 1 To nC) 'allow for headers?
If IncludeFieldNames Then
For c = 1 To nC
data(1, c) = rs.Fields(c - 1).Name
Next c
rowNum = 1
End If
For r = 1 To nR
rowNum = rowNum + 1
For c = 1 To nC
data(rowNum, c) = tmp(c - 1, r - 1)
Next c
Next r
RecordSetToArray = data
End Function
'Fill an array to a worksheet starting at `rng`, and return the filled range
Function ArrayToSheetRange(data, rng As Range) As Range
Dim rv As Range
Set rv = rng.Cells(1).Resize(UBound(data, 1), UBound(data, 2))
rv.Value = data
Set ArrayToSheetRange = rv
End Function
So I have this SQL Query
SELECT *
FROM [Employee To Manager]
WHERE [Employee To Manager].[Manager UID] In(getMyTeamUserNames());
Which has a VBA function getMyTeamUserNames()
Public Function getMyTeamUserNames() As String
Dim rs As DAO.Recordset
Dim dbs As DAO.Database
Set dbs = CurrentDb
getMyTeamUserNames = commaDelimitArray(getTeamUserNames(getUserName, dbs))
End Function
Public Function commaDelimitArray(arrayStr) As String
Dim sepStr As String
sepStr = "','"
commaDelimitArray = "'" & Join(arrayStr, sepStr)
End Function
Public Function getTeamUserNames(username, dbs) As String()
Dim sqlstatement As String
sqlstatement = "SELECT * FROM [Employee to Manager] WHERE [Employee to
Manager].[Manager UID] = '" & username & "'"
Set rs = dbs.OpenRecordset(sqlstatement, dbOpenSnapshot)
Dim ComputerUsernames() As String
Dim FindRecordCount As Integer
If rs.EOF Then
FindRecordCount = 0
Exit Function
Else
rs.MoveLast
FindRecordCount = rs.RecordCount
End If
ReDim ComputerUsernames(FindRecordCount) As String
Dim i As Integer
i = 0
rs.MoveFirst
Do Until rs.EOF = True
ComputerUsernames(i) = rs("Computer Username")
If (ComputerUsernames(i) <> "") Then
i = i + 1
End If
If (ComputerUsernames(i - 1) <> username) Then
Dim recurResult() As String
recurResult = getTeamUserNames(ComputerUsernames(i - 1), dbs)
Dim resultSize As Integer
If Len(Join(recurResult)) > 0 Then
resultSize = UBound(recurResult) - LBound(recurResult) + 1
ReDim Preserve ComputerUsernames(UBound(ComputerUsernames) + resultSize)
For Each resultStr In recurResult
ComputerUsernames(i) = resultStr
If (ComputerUsernames(i) <> "") Then
i = i + 1
End If
Next resultStr
End If
End If
rs.MoveNext
Loop
ReDim Preserve ComputerUsernames(i - 1)
getTeamUserNames = ComputerUsernames
End Function
Query runs and I get no data.
However if I take the result from getMyTeamUserNames() and put it in the query by hand it works. getMyTeamUserNames() result varies from possibly 2 results to 40 (recursively gets subordinates all the way down the tree).
So a C Perkins specifically pointed out this would never work so I have rebuilt the query with some other queries.
I am using VB6 in my system. I want to pass the selected row value of a datagrid to the textbox and edit the record. But I'm getting this error every time I run the code. "Either BOF or EOF is True, or the current record has been deleted. Requested operation requires a current record." Here's my codes in update button. Please help. Thanks in advance! :D
Private Sub cmdEdit_Click()
Dim conn As New Connection
Dim myRS As New Recordset
Dim sql As Integer
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;DataSource=C:\Users\FSCNDCIT\Desktop\GSTD\GSTDdb.mdb"
myRS.CursorLocation = adUseClient
myRS.Open "SELECT * FROM Table1 WHERE ID = '" & DataGrid1.Text & "'", conn, adOpenDynamic, adLockBatchOptimistic
frmGoSee.txtID.Text = myRS!ID 'This line was highlighted.
frmGoSee.txtGSTD.Text = myRS!GSTDCode
frmGoSee.txtGSTDCode.Text = myRS!WorkGroup
frmGoSee.txtTL.Text = myRS!TL
frmGoSee.txtDeptHead.Text = myRS!DeptHead
frmGoSee.txtParticipants.Text = myRS!Participants
frmGoSee.txtCoach.Text = myRS!Coach
frmGoSee.txtProblem_Des.Text = myRS!Problem_Des
frmGoSee.txtMI.Text = myRS!MI
frmGoSee.txtInter_Correction.Text = myRS!Inter_Correction
frmGoSee.txtICWho.Text = myRS!ICWho
frmGoSee.txtICWhen.Text = myRS!ICWhen
frmGoSee.txtICStatus.Text = myRS!ICStatus
frmGoSee.lblpicture.Caption = myRS!Picture
frmGoSee.Image1.Picture = LoadPicture(lblpicture)
myRS.Update
Set myRS = Nothing
conn.Close
End Sub
The error is telling you that the query did not bring back any records. Your code just assumes there will be a record. You should check for an empty recordset before trying to assign values.
Private Sub cmdEdit_Click()
Dim conn As New Connection
Dim myRS As New Recordset
Dim sql As Integer
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;DataSource=C:\Users\FSCNDCIT\Desktop\GSTD\GSTDdb.mdb"
myRS.CursorLocation = adUseClient
myRS.Open "SELECT * FROM Table1 WHERE ID = '" & DataGrid1.Text & "'", conn, adOpenDynamic, adLockBatchOptimistic
If myRS.EOF = False Then
frmGoSee.txtID.Text = myRS!ID 'This line was highlighted.
frmGoSee.txtGSTD.Text = myRS!GSTDCode
frmGoSee.txtGSTDCode.Text = myRS!WorkGroup
frmGoSee.txtTL.Text = myRS!TL
frmGoSee.txtDeptHead.Text = myRS!DeptHead
frmGoSee.txtParticipants.Text = myRS!Participants
frmGoSee.txtCoach.Text = myRS!Coach
frmGoSee.txtProblem_Des.Text = myRS!Problem_Des
frmGoSee.txtMI.Text = myRS!MI
frmGoSee.txtInter_Correction.Text = myRS!Inter_Correction
frmGoSee.txtICWho.Text = myRS!ICWho
frmGoSee.txtICWhen.Text = myRS!ICWhen
frmGoSee.txtICStatus.Text = myRS!ICStatus
frmGoSee.lblpicture.Caption = myRS!Picture
frmGoSee.Image1.Picture = LoadPicture(lblpicture)
'Commented because nothing in the record has changed
'There is nothing to update
'myRS.Update
End If
'checking the state of your objects here before closing would be good practice
If Not myRS Is Nothing Then
If myRS.State = adStateOpen Then
myRS.Close
End If
Set myRS = Nothing
End If
If Not conn Is Nothing Then
If conn.State = adStateOpen Then
conn.Close
End If
Set conn = Nothing
End If
End Sub
Please forgive the sloppy coding, but I was thrown onto a project to get data from a spreadsheet to SQL server and the deadline has been missed. I was able to initial get my first dataswipe using a SELECT statement, but I can't seem to switch it over to an UPDATE.
Here's the code. I get the runtime error 3704 operation not allowed when object is closed at the line rstRecordset.AddNew
Public cnnConn As ADODB.Connection
Public rstRecordset As ADODB.Recordset
Public cmdCommand As ADODB.Command
Public Const Server As String = "datguy"
Public SQLQuery As String
Option Explicit
Sub testupinsertupdate()
Dim wkb As Workbook
Dim wks As Worksheet
Dim sel As Range
Set wkb = ActiveWorkbook
Set wks = Sheets(1)
Set sel = Selection
With wks
'Declaration unit
Dim dataitem As String
Dim yr As Integer
Dim yrmax As Integer
Dim rxcount As Integer
Dim row As Integer
Dim col As String
Dim cleanup As String
Dim sqlrxcount As String
dataitem = .Range("B3").Value
yr = 6 'data only needs to go back to 2006
yrmax = .Range("C7").End(xlToRight).row + yr 'declarative count to the Right-Of-File
rxcount = 7
row = .Range("A" & .Rows.Count).End(xlUp).row 'declarative count to EOF
col = .Range("C6").End(xlToRight).Column
cleanup = "Data Unavailable"
sqlrxcount = .Range("A" & rxcount).Value
Set cnnConn = New ADODB.Connection
cnnConn.ConnectionString = "driver={SQL Server};server=" & Server & ";database=database;Trusted_Connection=Yes"
cnnConn.ConnectionTimeout = 800
cnnConn.Open
For rxcount = 7 To row
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand
.CommandTimeout = 0
.CommandText = "UPDATE table SET " & dataitem & " = '" & Cells(col).Value & "' WHERE RX_ID = '" & sqlrxcount & "'"
.CommandType = adCmdText
.Execute
Debug.Print cmdCommand.State
End With
Debug.Print cmdCommand.State
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
col = ("C" & rxcount)
For yr = 6 To yrmax
rstRecordset.AddNew '*** error pops!
rstRecordset.Fields("RX_ID") = Range("A" & rxcount).Value
rstRecordset.Fields("YEAR_REPORTED") = yr + 2000
If Range(col).Value = cleanup Then
rstRecordset.Fields(dataitem) = Null
Else: rstRecordset.Fields(dataitem) = Range(col).Value
End If
'debug line to show results
Debug.Print Range("A" & rxcount).Value, yr + 2000, Range(col).Value
col = Range(col).Offset(0, 1).Address
Next yr
Next rxcount
rstRecordset.UpdateBatch
rstRecordset.Close
cnnConn.Close
End With
End Sub
I don't feel like I'm doing the operations in order, but I'm just trying to get the initial load and then will worry about maintenance later. Why isn't the object(I assume this is the recordset) open when it was opened three lines before?
You are attempting to open a recordset based on an update not a select
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
should be something like
rstRecordset.Open "select * from table",cnnconn, adOpenStatic, adLockBatchOptimistic
Access Database Form1 is a Continuous Form that has an EmployeeID field you can double click to take you to another form that contains information about the Employee. In order to retain the correct employee I use this code...
Private Sub EmployeeID_DblClick(cancel as integer)
Dim myID as variant
myID = me.EmployeeID
DoCmd.OpenForm "frm_EmployeeInfo",,,,,,myID
End Sub
This Not only brings up the correct employee information but populates the number into a hidden textbox to retain the information.
On the Employee Form there is a TabControl with 4 tabs, one of the tabs contains a Continous subform that I am trying to populate employee information but instead of the information being populated down (let's say Employee X has 8 lines of different attributes to display) it is repeating the same one. Here is my code for the subform:
Option Compare Database
Private Sub Form_open(cancel As Integer)
Dim strConnection, strSQL As String
Dim conn As ADODB.Connection
Dim tbl As ADODB.Recordset
Dim SourceCode As String
Dim myID As Variant
Set conn = New ADODB.Connection
strConnection = "ODBC;Driver={SQLserver};DSN=AccessDatabase;Server=Labor;DATABASE=Source;Trusted_Connection=Yes;"
conn.Open strConnection
myID = CInt(Me.OpenArgs)
SourceCode= Nz(DLookup("[SourceCode]", "Locaton", "[LOC_ID] = Forms!frmUtility![Site].value"), "")
If SourceCode<> "" Then
strSQL = "SELECT EmployeeID,BenefitID,DeductionAmount,BenefitAmount,CoverageAmount,EffectiveDate,"
strSQL = strSQL & "EligibleDate,ExpirationDate FROM "
strSQL = strSQL & SourceCode & "_EmployeesBenefitsNew WHERE EmployeeID= " & myID
Else
strSQL = "SELECT EmployeeID,BenefitID,DeductionAmount,BenefitAmount,CoverageAmount,EffectiveDate,"
strSQL = strSQL & "EligibleDate,ExpirationDate FROM "
strSQL = strSQL & "EmployeesBenefitsNew WHERE EmployeeID= " & myID
End If
Set tbl = New ADODB.Recordset
With tbl
Set .ActiveConnection = conn
.Source = strSQL
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.CursorLocation = adUseClient
.Open
End With
With tbl
On Error Resume Next
.MoveFirst
Do Until tbl.EOF
Me.txtBenefitID.Value = tbl!BenefitID
Me.txtDeductionAmt.Value = tbl!DeductionAmount
Me.txtBenefitAmt.Value = tbl!BenefitAmount
Me.txtCoverageAmt.Value = tbl!CoverageAmount
Me.txtEffDt.Value = tbl!EffectiveDate
Me.txtTermDt.Value = tbl!ExpirationDate
Set Me.Recordset = tbl
.MoveNext
Loop
.Close
End With
conn.Close
Set conn = Nothing
Set tbl = Nothing
End Sub
Can anyone shed some light on this situation? Thanks!
You need to either set the recordset or the recordsource with the data, you cannot write to a continuous form on different lines, the lines only display as different if you have a recordset.
So
''********************
Set Me.Recordset = tbl
''********************
In you code:
Private Sub Form_open(cancel As Integer)
Dim strConnection, strSQL As String
Dim conn As ADODB.Connection
Dim tbl As ADODB.Recordset
Dim SourceCode As String
Dim myID As Variant
Set conn = New ADODB.Connection
strConnection = "ODBC;Driver={SQLserver};DSN=AccessDatabase;Server=Labor;DATABASE=Source;Trusted_Connection=Yes;"
conn.Open strConnection
myID = CInt(Me.OpenArgs)
SourceCode= Nz(DLookup("[SourceCode]", "Locaton", "[LOC_ID] = Forms!frmUtility![Site].value"), "")
If SourceCode<> "" Then
strSQL = "SELECT EmployeeID,BenefitID,DeductionAmount,BenefitAmount,CoverageAmount,EffectiveDate,"
strSQL = strSQL & "EligibleDate,ExpirationDate FROM "
strSQL = strSQL & SourceCode & "_EmployeesBenefitsNew WHERE EmployeeID= " & myID
Else
strSQL = "SELECT EmployeeID,BenefitID,DeductionAmount,BenefitAmount,CoverageAmount,EffectiveDate,"
strSQL = strSQL & "EligibleDate,ExpirationDate FROM "
strSQL = strSQL & "EmployeesBenefitsNew WHERE EmployeeID= " & myID
End If
Set tbl = New ADODB.Recordset
With tbl
Set .ActiveConnection = conn
.Source = strSQL
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.CursorLocation = adUseClient
.Open
End With
''********************
Set Me.Recordset = tbl
''********************
conn.Close
Set conn = Nothing
Set tbl = Nothing
End Sub