I have written some code to run when the Workbook is opened and it works flawlessly on my personal computer. However after sending the file to my laptop I get the "application-defined or object-defined error" message. I genuinely do not understand why this has happened or how I can solve this.
Private Sub Workbook_Open()
'loads the combobox when book opened
MenuGenerator.miscComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuMiscellaneous").RefersToRange)
MenuGenerator.soupCombobox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuSoups").RefersToRange)
MenuGenerator.saladComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuSalads").RefersToRange)
MenuGenerator.meatComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuMeat").RefersToRange)
MenuGenerator.fishComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuFish").RefersToRange)
MenuGenerator.starchComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuStarch").RefersToRange)
MenuGenerator.veggieComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuVegetable").RefersToRange)
MenuGenerator.dessertComboBox.List = Application.WorksheetFunction.Transpose(ThisWorkbook.Names("MenuDessert").RefersToRange)
End Sub
The code is set to load named ranges I created into the comboboxes.
Add a diagnostic message box to the code.
Option Explicit
Sub Workbook_Open()
Dim wb As Workbook, ws As Worksheet, i As Integer
Dim fn, arObj, arMenu, rng As Range, obj
Dim msg As String
Set fn = Application.WorksheetFunction
Set wb = ThisWorkbook
Set ws = wb.Sheets("MenuGenerator")
arObj = Array("misc", "soup", "salad", "meat", "fish", "starch", "veggie", "dessert")
arMenu = Array("Miscellaneous", "Soups", "Salads", "Meat", _
"Fish", "Starch", "Vegetable", "Dessert")
On Error Resume Next
For i = 0 To UBound(arObj)
Set rng = Nothing
Set obj = Nothing
msg = ""
Set rng = wb.Names("Menu" & arMenu(i)).RefersToRange
If rng Is Nothing Then
msg = msg & vbLf & "Error with name range 'Menu" & arMenu(i) & "'"
End If
Set obj = ws.OLEObjects(arObj(i) & "ComboBox")
If obj Is Nothing Then
msg = msg & vbLf & "Error with '" & arObj(i) & "ComboBox" & "'"
End If
If msg = "" Then
obj.Object.List = fn.Transpose(rng)
Else
MsgBox msg, vbExclamation
End If
Next
On Error GoTo 0
End Sub
Related
I am currently working on a VBA project. I have a workbook with multiple tabs from different workbooks. The names of all the tabs are the same, however since they come from different files, I would like to name them based on the filenames they are extracted from. The filenames are present in the cell EC1 of every tab. I would like to name all the sheets in the workbook based on the value present in cell EC1 of each individual sheet.
I have the following code:
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("EC1")
Next rs
End Sub
I have been getting a 1004 error from the above code.
I tried this code too:
Sub RenameSheet()
Dim xWs As Worksheet
Dim xRngAddress As String
Dim xName As String
Dim xSSh As Worksheet
Dim xInt As Integer
xRngAddress = Application.ActiveCell.Address
On Error Resume Next
Application.ScreenUpdating = False
For Each xWs In Application.ActiveWorkbook.Sheets
xName = xWs.Range(xRngAddress).Value
If xName <> "" Then
xInt = 0
Set xSSh = Nothing
Set xSSh = Worksheets(xName)
While Not (xSSh Is Nothing)
Set xSSh = Nothing
Set xSSh = Worksheets(xName & "(" & xInt & ")")
xInt = xInt + 1
Wend
If xInt = 0 Then
xWs.Name = xName
Else
If xWs.Name <> xName Then
xWs.Name = xName & "(" & xInt & ")"
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Some sheets do get renamed, however some do not. I have checked for duplicate sheet names, and there are none. I have also checked if the filename is in the correct range (cell), and it is present.
There might be problems with the value if it contains some special characters. The excel sheets can have some restrictions for their names, if thats the problem, my code could be the solution.
It cuts the string to a maximum length of 31 chars and deletes all the special chars which are not allowed in names.
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
sheetName = without_special_chars(rs.Range("EC1").Value)
If Len(sheetName) > 31 Then
sheetName = Left(sheetName, 31)
End If
rs.Name = sheetName
Next rs
End Sub
Function without_special_chars(text As String) As String
Dim i As Integer
Const special_chars As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{"
For i = 1 To Len(special_chars)
text = Replace(text, Mid(special_chars, i, 1), "")
Next i
without_special_chars = text
End Function
Rename Multiple Worksheets
A Quick Fix
Your first code should have been something like this:
Sub renameWorksheetsQF()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Name = ws.Range("EC1").Value
Next ws
End Sub
Note the not so subtile differences.
In Depth
Option Explicit
Sub renameWorksheets()
On Error GoTo clearError
Const cAddress As String = "A1" ' "EC1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim cel As Range
Dim oName As String
Dim nName As String
For Each ws In wb.Worksheets
oName = ws.Name
Set cel = ws.Range(cAddress)
If IsError(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' contains the error value '" & cel.Text & "'."
Else
If IsEmpty(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' is an empty cell."
Else
nName = CStr(cel.Value)
On Error GoTo RenameError
If oName <> nName Then
ws.Name = nName
Else
Debug.Print "Worksheet '" & oName _
& "' had previously been renamed."
End If
On Error GoTo clearError
End If
End If
Next ws
ProcExit:
Exit Sub
RenameError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Could not rename '" & oName & "' to '" & nName & "'."
Resume Next
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Unexpected error."
Resume ProcExit
End Sub
I am having some issues adding my signature into the Adobe PDF. For some reason, I can't add my digital ID into the PDF using the additional code.
I keep on getting a Run-Time Error '13': Type Mismatch
Any suggestions?
I got the macro working so that it adds in the Signature field using the following code -
Sub Prepare_PDF()
On Error GoTo Err_Handler
Dim pdfPDDoc As New AcroPDDoc, oJS As Object, oFields, oAttachment As Object
Dim strFName As String
Dim strSignature As String
Dim strSignFName As String
Dim oParam As Parameter
strFName = "70145173 - 0100771347.pdf"
'------- Add signature fields to PDF file----------
If pdfPDDoc.Open(strFName) Then
Set oJS = pdfPDDoc.GetJSObject
Set oFields = oJS.AddField("SignatureField1", "signature", 0, Array(200, 620, 450, 670))
'------- Save PDF file------------------
strFName = Left(strFName, Len(strFName) - 4) & "-signed.pdf"
pdfPDDoc.Save 1, strFName
End If
Exit_Proc:
Exit Sub
Err_Handler:
MsgBox "In test" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Sub
Now when I add this code in to get my digital ID added, it error's out.
Sub Prepare_PDF()
On Error GoTo Err_Handler
Dim pdfPDDoc As New AcroPDDoc, oJS As Object, oFields, oAttachment As Object
Dim strFName As String
Dim strSignature As String
Dim oPpklite As Object
Dim strSignFName As String
Dim oParam As Parameter
strFName = "A:\PDF File\Cost Transfer - 70145173 - 0100771347.pdf"
strSignature = "C:\Users\Desktop\FirstName.pfx"
'------- Add signature fields to PDF file----------
If pdfPDDoc.Open(strFName) Then
Set oJS = pdfPDDoc.GetJSObject
Set oFields = oJS.AddField("SignatureField1", "signature", 0, Array(200, 620, 450, 670))
Set oSign = oJS.GetField("SignatureField1")
Set oPpklite = oJS.security.getHandler("Adobe.PPKLite", True)
oPpklite.login "{'Password', '" & strSignature & "'}"
oSign.signatureSign oPpklite
oPpklite.logout
'------- Save PDF file------------------
strFName = Left(strFName, Len(strFName) - 4) & "-signed.pdf"
pdfPDDoc.Save 1, strFName
End If
Exit_Proc:
Exit Sub
Err_Handler:
MsgBox "In test" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Sub
This is what works for me: i do the signing in two steps. (i did it in Access, but it should be almost the same for Excel)
Option Compare Database
Option Explicit
'the position of the signing box on the PDF
Const Y = 524
Const X = 14
Const W = 106
Const H = 59
Public Function PreparePDF(InputPDF As String) As Boolean
On Error GoTo Err_Handler
Dim pdfPDDoc As Acrobat.AcroPDDoc
Dim OutputPdf As String: OutputPdf = "C:\fact\Temp.pdf"
'it needs to be an array
Dim sg_arr() As Variant: sg_arr = Array(X, Y + H, X + W, Y)
Dim oJS As Object
Dim oPpklite As Object
Dim SignField As Object
Dim HadError As Boolean: HadError = False
Set pdfPDDoc = New AcroPDDoc
If pdfPDDoc.Open(InputPDF) Then
Set oJS = pdfPDDoc.GetJSObject
Set oPpklite = oJS.security.getHandler("Adobe.PPKLite")
'add the signature field to the PDF, then save and close. Otherwise,
'Acrobat will give the following message:
'"GeneralError: Operation failed. Field.signatureSign:0: This operation cannot be done before the document has finished downloading. Please try again later."
Set SignField = oJS.AddField("Sgn", "signature", 0, sg_arr)
pdfPDDoc.Save 1, OutputPdf
End If
Exit_Proc:
If Not oPpklite Is Nothing Then oPpklite.logout
Set oJS = Nothing
Set oPpklite = Nothing
Set pdfPDDoc = Nothing
If Not HadError Then
If SignPDF(InputPDF) Then
MsgBox "Successfully signed " & InputPDF & "!", vbOKOnly + vbInformation
Dim Fso As New FileSystemObject
Fso.DeleteFile "C:\fact\Temp.pdf", True
Set Fso = Nothing
PreparePDF = True
Else
PreparePDF = False
End If
Else
PreparePDF = False
End If
Exit Function
Err_Handler:
HadError = True
Debug.Print "In SignPDF" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Function
Public Function SignPDF(OutputPdf As String) As Boolean '(inputpdf As String, outputpdf As String)
On Error GoTo Err_Handler
Dim InputPDF As String: InputPDF = "C:\fact\temp.pdf"
Dim strSignFName As String: strSignFName = "C:\fact\PFA.pfx"
Dim pass As String: pass = "******"
Dim pdfApp As Acrobat.AcroApp
Dim pdfPDDoc As Acrobat.AcroPDDoc
Dim oJS As Object
Dim oSign As Object
Dim oPpklite As Object
Dim ResultLogin As Boolean
Dim ResultSign As Boolean
Dim arr() As String
Set pdfApp = New AcroApp
Set pdfPDDoc = New AcroPDDoc
If pdfPDDoc.Open(InputPDF) Then
Set oJS = pdfPDDoc.GetJSObject
Set oPpklite = oJS.security.getHandler("Adobe.PPKLite")
ResultLogin = oPpklite.login(pass, "C:\fact\PFA.pfx")
oPpklite.setPasswordTimeout pass, 200
Set oSign = oJS.GetField("Sgn")
arr = VBA.Split("", ",")
ResultSign = oSign.signatureSign(oPpklite, arr, OutputPdf)
End If
SignPDF = True
Exit_Proc:
If Not oPpklite Is Nothing Then oPpklite.logout
If Not pdfApp Is Nothing Then
pdfApp.CloseAllDocs
pdfApp.Hide
pdfApp.Exit
End If
Set oJS = Nothing
Set oSign = Nothing
Set oPpklite = Nothing
Set pdfPDDoc = Nothing
Set pdfApp = Nothing
Exit Function
Err_Handler:
SignPDF = False
Debug.Print "In SignPDF" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Function
And to call it:
PreparePDF "pdf_file_to_be_signed.pdf"
Obviously you need to reference acrobat.tlb
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 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
I'm trying to create a macro for a command button that when clicked, will get the job number from that row and look for a file for that job. If it does not exist I want it to copy from a template and save with a new name, otherwise just open the file.
However, I cannot seem to work out how to get hold of the information for the command button that calls the macro. This is what I have so far:
Public Function ShapeExists(OnSheet As Object, Name As String) As Boolean
On Error GoTo ErrShapeExists
If Not OnSheet.Shapes(Name) Is Nothing Then
ShapeExists = True
End If
ErrShapeExists:
Exit Function
End Function
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim buttonName As String
buttonName = (Target.Row - 1)
If Not ShapeExists(ActiveSheet, buttonName) Then
If Range("O" & Target.Row).Value = "" And Target.Column <= 14 And Target.Row > 1 Then
ActiveSheet.Buttons.Add(910.5, Range("O" & Target.Row).Top, 80, 20).Select
Selection.Name = buttonName
Selection.OnAction = "Sheet1.JobButton"
ActiveSheet.Shapes(buttonName).Select
Selection.Characters.Text = "Open Job"
End If
End If
End Sub
Private Sub JobButton()
Dim newText As String
ActiveSheet.Shapes(Application.Caller).Select
If Range("N" & Selection.TopLeftCell.Row).Value <> "" Then
newText = "Job " & Range("N" & Selection.TopLeftCell.Row).Value
Dim checkFilename As String
Dim check As String
check = "N" & Selection.TopLeftCell.Row
checkFilename = newText & ".xlsm"
If Dir(checkFilename) <> "" Then
Workbooks.Open (newText)
Else
Dim SrcBook As Workbook
Set SrcBook = ThisWorkbook
Dim NewBook As Workbook
NewBook = Workbooks.Open("Job Template.xlsm")
SrcBook.Worksheets(1).Range("D" & Selection.TopLeftCell.Row).Copy
NewBook.Worksheets(2).Range("B15").PasteSpecial
With NewBook
.Title = newText
.Subject = newText
.SaveAs Filename:=newText
End With
End If
Else
ErrMsg:
MsgBox ("Job Should always have a number."), , "NO JOB NUMBER"
End If
End Sub
As you can see I am currently trying ActiveSheet.Shapes(Application.Caller).Select, this is causing a "Run-time error '13': Type mismatch".
Any help would be much appreciated, thank you!
Right-click the button --> View Code --> put your JobButton code here