I have created an excel linked access database with VBA that works when I use a centrally saved version but not when I save a local copy.
I have used the Debug tool and the code skips my For loop in the locally saved copy.
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Sheet18.Cells(x, i).Value
Next i
DatabaseData.Update
Next x
I think that this is because the Recordset (DatabaseData) is not being recognized (not sure if that is the correct term).
The code is below
Sub CopyDatatoAccess()
Dim DatabaseConn As ADODB.Connection
Dim DatabaseData As ADODB.Recordset
Dim Pathway
Dim x As Long, i As Long
Dim nextrow As Long
On Error GoTo errorhandler:
Pathway = Sheet18.Range("AQ2").Value
nextrow = Sheet18.Range("AR2")
Set DatabaseConn = New ADODB.Connection
If Sheet18.Range("A2").Value = "" Then
MsgBox "ARF form is not present for Upload"
Exit Sub
End If
DatabaseConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Pathway
Set DatabaseData = New ADODB.Recordset
DatabaseData.Open Source:="ARFs", _
ActiveConnection:=DatabaseConn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Sheet18.Cells(x, i).Value
Next i
DatabaseData.Update
Next x
DatabaseData.Close
DatabaseConn.Close
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "The ARF is now uploaded"
Application.ScreenUpdating = True
Sheet18.Cells.Range("AK2").Value = Sheet18.Cells.Range("AK4").Value + 1
On Error GoTo 0
Exit Sub
errorhandler:
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
Related
In Excel VBA, if a variable is Excel.Range, and the range it refers to is deleted, it loses its reference. Any attempt to access the variable results in Runtime Error 424: object required.
Dim rng As Range
Set rng = Sheet1Range("A1")
Sheet1.Rows(1).Delete 'Range has been deleted.
Debug.Print rng.Address() 'Any access attempt now raises runtime error 424.
Is there a way to test for this state of "lost reference" without an error handler..?
Testing Nothing, Vartype(), and Typename() were all not useful because the variable is still a Range. I literally read through all of Excel.Application in the Object browser, but found nothing. Perhaps there's something I'm overlooking..? Such as one of those strange vestigial functions from prehistoric versions of Excel, like ExecuteExcel4Macro()..?
I've searched Google for the answer to this question, but didn't find anything helpful.
EDIT:
Some have asked why I'm trying to avoid an error handler. This is my normal programming philosophy for a couple reasons:
I do recognize that sometimes an error handler is the quickest way, or the only way. But it's not the most elegant way. It just seems, well...crude to me. It's like the difference between white-washing a picket fence and painting a portrait of my cat. =-)
The other reason I avoid error handlers is education. Many times when searching for an alternative, I'll discover properties, procedures, objects, or even entire libraries that I never knew before. And in doing so I find more armor with which to bulletproof my code.
Here's an approach that should be able to workaround the issue, although it isn't a great solution for checking if it was removed by itself. I think error handling is probably your best approach.
Sub Example()
Dim foo1 As Range
Dim foo2 As Range
Dim foo3 As Range
Dim numberOfCells As Long
Set foo1 = Sheet1.Range("A1")
Set foo2 = foo1.Offset(1, 0) 'Get the next row, ensure this cell exists after row deletion!
Set foo3 = Union(foo1, foo2)
numberOfCells = foo3.Cells.Count
Debug.Print "There are " & numberOfCells & " cells before deletion"
Sheet1.Rows(1).Delete
Debug.Print "There are now " & foo3.Cells.Count & " cells"
If foo3.Cells.Count <> numberOfCells Then
Debug.Print "One of the cells was deleted!"
Else
Debug.Print "All cells still exist"
End If
End Sub
Also, here is a more function oriented approach which may be a slightly better approach to add to your codebase. Again, not ideal, but it should not require an error handler.
Private getRange As Range
Sub Example()
Dim foo As Range
Dim cellCount As Long
Set foo = Sheet1.Range("A1")
cellCount = GetCellCountInUnion(foo)
Sheet1.Rows(1).Delete
If Not cellCount = getRange.Cells.Count Then
Debug.Print "The cell was removed!"
Else
Debug.Print "The cell still exists!"
End If
End Sub
Private Function GetCellCountInUnion(MyRange As Range) As Long
Set getRange = Union(MyRange, MyRange.Parent.Range("A50000")) ‘second cell in union is just a cell that should exist
GetCellCountInUnion = getRange.Cells.Count
End Function
Just in case someone needs a solution for this problem and doesn't mind using the error handler.
Option Explicit
Public Sub Example()
Dim rng1 As Range, rng2 As Range
Set rng1 = Range("A1")
Set rng2 = Range("A2")
ActiveSheet.Rows(1).Delete ' rng1 will loose its reference
Debug.Print "rng1 has reference? : " & RangeHasReference(rng1)
Debug.Print "rng2 has reference? : " & RangeHasReference(rng2)
End Sub
Private Function RangeHasReference(rng As Range) As Boolean
Dim Creator As Long
On Error Resume Next
Creator = rng.Creator ' try access some property
RangeHasReference = (Err.Number <> 424)
End Function
An example using a range name:
Dim ws As Worksheet, rng As Range, nm As Name
Set ws = ActiveSheet
Set rng = ws.Range("A2")
Names.Add Name:="testName", RefersTo:=rng
Set nm = Application.Names("testName")
ws.Rows(2).Delete 'Range has been deleted.
If InStr(1, nm.RefersTo, "#REF!") > 0 Then
'If InStr(1, Names("testName").RefersTo, "#REF!") > 0 Then
Debug.Print "lost reference"
Else
Debug.Print rng.Address()
End If
nm.Delete
'Names.Add Name:="testName", RefersTo:=""
Below an example of a sheet module to synchronize from an excel listobject to a database table (ms access).
UPDATE Jul 05, 20': some testing with the code below seems to shows a lost of info about the counter of selected rows/columns in the "names" editor window panel (top left, next to formula editor) in cases of multiple cell selections.
Private IdAr As Variant, myCount As Integer
Private Sub Worksheet_Activate()
Names.Add Name:="myName", RefersTo:=Selection, Visible:=False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count = Me.Rows.Count Then Exit Sub
On Error GoTo ExceptionHandling
Names.Add Name:="myName", RefersTo:=Target, Visible:=False
If Not Application.Intersect(Target, Me.ListObjects("Table2").DataBodyRange) Is Nothing Then
Dim tblRow As Long, y As Integer, i As Integer
tblRow = Target.Row - Me.ListObjects("Table2").HeaderRowRange.Row
y = Target.Rows.Count
If y > 1 Then
ReDim IdAr(0 To y - 1)
For i = 0 To y - 1
IdAr(i) = Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow + i)
Next i
Else
'If Application.CutCopyMode = False Then
IdAr = Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow).Value
'End If
End If
End If
CleanUp:
On Error Resume Next
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description
Resume CleanUp
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ExceptionHandling
Application.EnableEvents = False
If Not Application.Intersect(Target, Me.ListObjects("Table2").DataBodyRange) Is Nothing Then
Dim myCell As Range
For Each myCell In Target
If Not Application.Intersect(myCell, Me.ListObjects("Table2").ListColumns("ID").DataBodyRange) Is Nothing Then
If InStr(1, Names("myName").RefersTo, "#") > 0 Then
Debug.Print "Lost reference"
Delete_record
myCount = myCount + 1
Cancelado = True
Else
If myCell.Text = vbNullString Then
Debug.Print "Selecting listObject row and clear contents"
Delete_record
myCount = myCount + 1
Cancelado = True
End If
End If
Else
If Cancelado = False Then
If Not Application.Intersect(myCell, Me.Range("Table2[[FIELD1]:[FIELD3]]")) Is Nothing Then Update_record myCell
End If
End If
Next myCell
End If
CleanUp:
On Error Resume Next
myCount = 0
Application.EnableEvents = True
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description
Resume CleanUp
End Sub
Sub Update_record(myCell As Range)
On Error GoTo ExceptionHandling
Dim tblRow As Long, IdTbl As Long, sField As String, sSQL As String
sField = Me.ListObjects("Table2").HeaderRowRange(myCell.Column)
tblRow = myCell.Row - Me.ListObjects("Table2").HeaderRowRange.Row
IdTbl = Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow).Value
'Dim cnStr As String
'cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath & ";Jet OLEDB:Database Password=123"
'Dim cn As ADODB.Connection
'Set cn = New ADODB.Connection
'cn.CursorLocation = adUseServer
'cn.Open cnStr
If IdTbl > 0 Then
sSQL = "UPDATE MYTABLE SET " & sField & " = '" & myCell.Value & "' WHERE ID = " & Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow).Value
MsgBox sSQL
'Dim cmd As ADODB.Command
'Set cmd = New ADODB.Command
'Set cmd.ActiveConnection = cn
'cmd.CommandText = sSQL
'cmd.Execute , , adCmdText + adExecuteNoRecords
''cn.Execute sSQL, RecsAffected 'alternative to Command
''Debug.Print RecsAffected
Else
sSQL = "SELECT ID, " & sField & " FROM MYTABLE"
MsgBox sSQL
'Dim rst As ADODB.Recordset
'Set rst = New ADODB.Recordset
'rst.Open sSQL, cn, adOpenForwardOnly, adLockOptimistic, adCmdText
'cn.BeginTrans
'rst.AddNew
'rst(sField).Value = myCell.Value
'rst.Update
'IdTbl = rst(0).Value
'MsgBox "New Auto-increment value is: " & IdTbl
'tbl.ListColumns("ID").DataBodyRange(Fila) = IdTbl
'rst.Close
'cn.CommitTrans
End If
CleanUp:
On Error Resume Next
cn.Close
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description & vbLf & Err.Number
Resume CleanUp
Resume 'for debugging
End Sub
Sub Delete_record()
Dim sSQL As String
If IsArray(IdAr) Then
sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr(myCount)
MsgBox sSQL
Else
sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr
MsgBox sSQL
End If
End Sub
UPDATE Aug 02 '20 Finally i'm using the code below for detecting deleted rows and upward synchronizing from an excel ListObject table to a database table:
Private IdAr As Variant, tbRows As Integer, myCount As Integer, Cancelado As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count = Me.Rows.Count Then Exit Sub
On Error GoTo ExceptionHandling
If Not Application.Intersect(Target, Me.ListObjects("Table1").DataBodyRange) Is Nothing Then
Dim tblRow As Long, y As Integer, i As Integer
tblRow = Target.Row - Me.ListObjects("Table1").HeaderRowRange.Row
y = Target.Rows.Count
If y > 1 Then
ReDim IdAr(0 To y - 1)
For i = 0 To y - 1
IdAr(i) = Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow + i)
Next i
Else
'If Application.CutCopyMode = False Then
IdAr = Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow).Value
'End If
End If
tbRows = Me.ListObjects("Table1").ListRows.Count
End If
CleanUp:
On Error Resume Next
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description
Resume CleanUp
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ExceptionHandling
Application.EnableEvents = False
If Not Application.Intersect(Target, Me.ListObjects("Table1").DataBodyRange) Is Nothing Then
Cancelado = False
Dim myCell As Range
For Each myCell In Target
If Not Application.Intersect(myCell, Me.ListObjects("Table1").ListColumns("ID").DataBodyRange) Is Nothing Then
If Me.ListObjects("Table1").ListRows.Count > tbRows Then
Cancelado = True
Else
If Me.ListObjects("Table1").ListRows.Count = tbRows Then
If myCell.Text = vbNullString Then
Debug.Print "Selected ListObject Row and Cleared Contents"
Cancelado = True
Delete_record
myCount = myCount + 1
End If
Else
Cancelado = True
Debug.Print "ListObject Row Deleted"
Delete_record
myCount = myCount + 1
End If
End If
Else
If Cancelado = False Then
If Not Application.Intersect(myCell, Me.Range("Table1[[FIELD1]:[FIELD3]]")) Is Nothing Then Update_record myCell
End If
End If
Next myCell
End If
CleanUp:
On Error Resume Next
myCount = 0
Application.EnableEvents = True
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description & vbLf & Err.Number
Resume CleanUp
Resume 'for debugging
End Sub
Sub Update_record(myCell As Range)
On Error GoTo ExceptionHandling
Dim tblRow As Long, IdTbl As Long, sField As String, sSQL As String
sField = Me.ListObjects("Table1").HeaderRowRange(myCell.Column)
tblRow = myCell.Row - Me.ListObjects("Table1").HeaderRowRange.Row
IdTbl = Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow).Value
'Dim cnStr As String
'cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath & ";Jet OLEDB:Database Password=123"
'Dim cn As ADODB.Connection
'Set cn = New ADODB.Connection
'cn.CursorLocation = adUseServer
'cn.Open cnStr
If IdTbl > 0 Then
sSQL = "UPDATE MYTABLE SET " & sField & " = '" & myCell.Value & "' WHERE ID = " & Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow).Value
MsgBox sSQL
'Dim cmd As ADODB.Command
'Set cmd = New ADODB.Command
'Set cmd.ActiveConnection = cn
'cmd.CommandText = sSQL
'cmd.Execute , , adCmdText + adExecuteNoRecords
''cn.Execute sSQL, RecsAffected 'alternative to Command
''Debug.Print RecsAffected
Else
sSQL = "SELECT ID, " & sField & " FROM MYTABLE"
MsgBox sSQL
'Dim rst As ADODB.Recordset
'Set rst = New ADODB.Recordset
'rst.Open sSQL, cn, adOpenForwardOnly, adLockOptimistic, adCmdText
'cn.BeginTrans
'rst.AddNew
'rst(sField).Value = myCell.Value
'rst.Update
'IdTbl = rst(0).Value
'MsgBox "New Auto-increment value is: " & IdTbl
'Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow) = IdTbl
'rst.Close
'cn.CommitTrans
End If
CleanUp:
On Error Resume Next
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
End If
'DriveMapDel
'https://codereview.stackexchange.com/questions/143895/making-repeated-adodb-queries-from-excel-sql-server
'... get rid of the redundant assignments to Nothing; the objects are going out of scope at End Sub, they're being destroyed anyway.
'Set rst = Nothing
'Set cmd = Nothing
'Set cn = Nothing
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description & vbLf & Err.Number
Resume CleanUp
Resume 'for debugging
End Sub
Sub Delete_record()
Dim sSQL As String
If IsArray(IdAr) Then
sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr(myCount)
MsgBox sSQL
Else
sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr
MsgBox sSQL
End If
End Sub
I'm trying to execute a macro from a new worksheet with a button so that it runs in another worksheet (named "ARF Export").
Unfortunately I don't know how to set the worksheet I want the macro to run in to ("ARF Export"). Please could you advise me on how to proceed?
The error I get when I run this code in a different sheet is:
Error 3265 Item cannot be found in the collection corresponding to the requested name or ordinal in procedure export_data
When I step into Debug I don't get an error until the end but it skips through my For Loop on line 38 next i
for x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Worksheets("ARF Export").Cells(x, i).Value
Next i
DatabaseData.Update
Next x
All code below---
Option Explicit
Sub CopyDatatoAccess()
Dim DatabaseConn As ADODB.Connection
Dim DatabaseData As ADODB.Recordset
Dim Pathway
Dim x As Long, i As Long
Dim nextrow As Long
On Error GoTo errorhandler:
Pathway = Worksheets("ARF Export").Range("AR2").Value
nextrow = Worksheets("ARF Export").Range("As2").Value
Set DatabaseConn = New ADODB.Connection
If Worksheets("ARF Export").Range("A2").Value = "" Then
MsgBox "ARF form is not present for Upload"
Exit Sub
End If
DatabaseConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Pathway
Set DatabaseData = New ADODB.Recordset
DatabaseData.Open Source:="ARFs", _
ActiveConnection:=DatabaseConn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Worksheets("ARF Export").Cells(x, i).Value
Next i
DatabaseData.Update
Next x
DatabaseData.Close
DatabaseConn.Close
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "The ARF is now uploaded"
Application.ScreenUpdating = True
Worksheets("ARF Export").Cells.Range("AK2").Value = Worksheets("ARF Export").Cells.Range("AK4").Value
Worksheets("ARF Export").Cells.Range("AK5").Value = Worksheets("ARF Export").Cells.Range("AK4").Value + 1
On Error GoTo 0
Exit Sub
errorhandler:
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
Thanks for the help
-Turns out I needed to reference DatabaseData(Cells(1, i).Value) once i did this
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Worksheets("ARF Export").Cells(1, i).Value) = Worksheets("ARF Export").Cells(x, i).Value
Next i
DatabaseData.Update
Next x
It worked great. Thank you for your help all!
I am working on an Excel application which allows users to enter hours work through userforms and info is stored in a Access DB. I am new to excel and access connections. I am able to connect to the database but record is not saved/created due to a run-time error at the .Update command.
Run-Time Error '-2147467259 (80004005)': Operation must use an updatable query.
I have searched and searched and can't find a solution to this problem. I hope someone is able to help. (code below)
Sub Export_Data_Access_TI1()
Dim dbPath As String
Dim x As Long, i As Long
Dim nextrow As Long
Dim user As String
Dim NewSht As Worksheet
Dim strQuery As String
Dim recDate As String
Dim Week_Of As String
user = Sheet1.Range("A1").Text
On Error GoTo ErrHandler:
'Variables for file path and last row of data
dbPath = "H:\PROJECTS\CAI_DOT-Time Tracker\CAI_EMP_SignIn_Database.accdb"
nextrow = Cells(Rows.Count, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Check for data
If Sheets(user).Range("A2").Value = "" Then
MsgBox " There is no data to send to MS Access"
Exit Sub
End If
cnn.Mode = adModeReadWrite
'cnn.Mode = adModeShareDenyNone
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.CursorLocation = adUseClient
rst.Open Source:="DATA", ActiveConnection:=cnn, _
CursorType:=adOpenKeyset, LockType:=adLockPessimistic, _
Options:=adCmdTable
'rst.Supports (adAddNew)
x = 2 'the start row in the worksheet
Do While Len(Sheets(user).Range("A" & x).Formula) > 0
With rst
.AddNew 'create a new record
.Fields("Date") = ActiveWorkbook.Sheets(user).Range("A" & x).Value
.Fields("Week_Of") = Sheets(user).Range("B" & x).Value
.Fields("Month") = Sheets(user).Range("C" & x).Value
.Fields("Name") = Sheets(user).Range("D" & x).Value
.Fields("Time_In") = Sheets(user).Range("E" & x).Value
.Fields("Time_Out") = Sheets(user).Range("F" & x).Value
.Fields("Time_In2") = Sheets(user).Range("G" & x).Value
.Fields("Time_Out2") = Sheets(user).Range("H" & x).Value
.Fields("Group") = Sheets(user).Range("I" & x).Value
.Fields("UniqueID") = Sheets(user).Range("J" & x).Value
.Fields("Comments") = Sheets(user).Range("K" & x).Value
.Update 'stores the new record
End With
x = x + 1 'next row
Loop
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
'communicate with the user
MsgBox " The data has been successfully sent to the access database"
'Update the sheet
Application.ScreenUpdating = True
'Clear the data
'Sheets(user).Range("A1:K1000").ClearContents
On Error GoTo 0
Exit Sub
ErrHandler:
'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
As I understand, DATA is a query in the remote accdb. If so, it should be updateable. See, for example this: Why is my query not updateable? for criterias. If this is a table, check if you have read-write rights on accdb and the file has no read-only attribute.
I am exporting data from Excel to Access. The data in Excel contains formulas, which are leaving cells blanks with if function: =IF(SISESTUS!B18="";"";SISESTUS!C18.
Problem is: VBA is not capable of reading blank cells with formulas. This raises a type mismatch error. When I copy only values then is ok, my export macro runs perfectly.
Code:
Sub Export_Data()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim dbPath
Dim x As Long, i As Long
Dim nextrow As Long
On Error GoTo errHandler:
dbPath = ActiveSheet.Range("S3").Value
nextrow = Cells(Rows.Count, 1).End(xlUp).row
Set cnn = New ADODB.Connection
If Sheet8.Range("A2").Value = "" Then
MsgBox " Lisa kirjed tellimusse, midagi pole arhiveerida"
Exit Sub
End If
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset
rst.Open Source:="Tellimused", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
For x = 2 To nextrow
rst.AddNew
For i = 1 To 16
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox " Tellimus on edukalt arhiiveeritud"
Application.ScreenUpdating = True
Sheet8.Range("R3").Value = Sheet8.Range("T3").Value + 1
Sheet8.Range("A2:P250").ClearContents
On Error GoTo 0
Exit Sub
errHandler:
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
I think, after these lines code, macro ends and give a error messages. For clarity.
For x = 2 To nextrow
rst.AddNew
For i = 1 To 16
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x
I would recommend to use some recognizable value in your formula that the macro can read (like 999999) instead of "" and handle it inside macro:
If Cells(x, i).Value <> 999999 Then
rst(Cells(1, i).Value) = Cells(x, i).Value
Else
rst(Cells(1, i).Value) = "" ' or skip
End If
I fix my problem with paste if anybody got similar issue:
Sub Copy_Data()
Worksheets("Sheet1").Range("A2:P250").Copy
Worksheets("Sheet1").Range("U2:AJ250").PasteSpecial xlPasteValues
End Sub
I have created a form in which when I click a button(subMnuPrintStaff), it should open an Excel file(WorkerNames.xls). The Excel file gets its records from my database(Employee.mdb). However, the problem is that when I update my databasefile(Employee.mdb), the records on my Excel file does not get updated. How do I fix this?
I am using flexgrid.
BUTTON CODE:
Private Sub subMnuPrintStaff_Click()
'On Error GoTo er
Dim oExcel As Object
Set oExcel = CreateObject("Excel.Application")
Dim oWorkBook As Object
Dim oWorkSheet As Object
Dim i As Integer, k As Integer
Dim lRow As Long
Dim LastRow As Long
Dim LastCol As Long
oExcel.Visible = False
oExcel.Workbooks.Open App.Path & "\WorkerNames.xls"
Set oWorkSheet = oExcel.Workbooks("WorkerNames.xls").Sheets("WorkerNames")
i = 2 'Row in Excel
LastRow = DataGrid1.Row 'Save Current row
LastCol = DataGrid1.Col 'and column
DataGrid1.Row = 0 'Fixed Row is -1
Do While DataGrid1.Row <= DataGrid1.VisibleRows - 1
For k = 1 To DataGrid1.Columns.Count - 1
DataGrid1.Col = k 'Fixed Column is -1
oWorkSheet.Cells(i, k).Font.Bold = False
oWorkSheet.Cells(i, k).Font.Color = vbBlack
oWorkSheet.Cells(i, k).Value = DataGrid1.Text
Next
i = i + 1
If DataGrid1.Row < DataGrid1.VisibleRows - 1 Then
DataGrid1.Row = DataGrid1.Row + 1
Else
Exit Do
End If
Loop
DataGrid1.Row = LastRow 'Restore original Row
DataGrid1.Col = LastCol 'and Column
oExcel.Workbooks("WorkerNames.xls").Save
oExcel.Workbooks("WorkerNames.xls").Close savechanges:=True
oExcel.Quit
'cmdView.Enabled = True
'er:
'If err.Number = 1004 Then
'Exit Sub
'End If
On Error GoTo ErrHandler
Dim xlApp As Object
Dim xlWB As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open("WorkerNames.xls")
Exit Sub
ErrHandler:
MsgBox "There is a problem opening that workbook!", vbCritical, "Error!"
End Sub
FORM LOAD CODE:
Dim oRs As New ADODB.Recordset
Dim adoConn2 As ADODB.Connection
Set adoConn2 = New ADODB.Connection
adoConn2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & App.Path & "\Employee.mdb"
adoConn2.Open
oRs.CursorLocation = adUseClient
oRs.Open "select * from employeeName", adoConn2, adOpenKeyset, adLockPessimistic
Set DataGrid1.DataSource = oRs
DataGrid1.Refresh
Any help would be greatly appreciated. Database and Excel files are in the same directory with the project.
CODE FOR SAVING DATA INTO MY DATABASE - using text boxes
Dim adoConn As New ADODB.Connection Dim constr, curSql As String constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\employee.mdb;Persist Security Info=False"
Set adoConn = New ADODB.Connection
adoConn.ConnectionString = constr adoConn.Open
If txtFirstName.Text = "" Or txtLastName.Text = "" Then
MsgBox "Some fields are empty!", vbInformation + vbOKOnly, "Empty Fields"
Else curSql = "INSERT INTO employeename(Firstname, LastName) VALUES ("curSql = curSql & "'" & Replace(txtFirstName.Text, "'", "''") & "'," curSql = curSql & "'" & Replace(txtLastName.Text, "'", "''") & "')"
adoConn.Execute curSql
adoConn.Close
MsgBox "Data successfully added!", vbOKOnly, "Success!"
txtFirstName.Text = ""
txtLastName.Text = ""