Issues executing a ADO Macro from new sheet - excel

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!

Related

Excel Deletes query table connection while running VBA macro

I am struggling with an interesting problem that I have never experienced before and cannot seem to find any information about online. Here is the setup:
I am looping through a set of rows in a table - each row has a column for sheet name and a link from which I want to webscrape some data. I have written VBA code which loops through each row, creates a new sheet with the correct name, creates a querytable in that sheet, web scrapes the correct link and deletes the querytable.
Here is the code:
Sub WQ_Refresh(wsname As String, wqName As String, wqURL As String, strFC As String)
Dim ws As Worksheet
Dim wq As QueryTable
Dim errno As Long
Dim loopcnt As Integer
Dim refreshTime As Double
Dim lastrow As Long
refreshTime = Timer
Application.StatusBar = "Now downloading " & wqName & " for " & strFC
If wsname = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets(wsname)
If ws.QueryTables.Count > 0 Then
Set wq = ws.QueryTables(1)
wq.Delete
End If
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lastrow > 1 Then lastrow = lastrow + 1
Set wq = ws.QueryTables.Add(Connection:="URL;" & wqURL, Destination:=ws.Range("A" & lastrow))
errno = 1
loopcnt = 0
Do While Not (errno = 0 And loopcnt < 10)
On Error Resume Next
With wq
.FieldNames = True
.WebFormatting = xlWebFormattingNone
.WebSelectionType = xlAllTables
.Refresh BackgroundQuery:=False
.Delete
End With
loopcnt = loopcnt + 1
errno = Err.Number
If loopcnt = 10 Then HashtagFail wqName
On Error GoTo 0
Loop
If lastrow > 1 Then
ws.Rows(lastrow - 1 & ":" & lastrow).Delete
End If
Set wq = Nothing
Application.StatusBar = "Downloaded " & wqName & " in " & Round(Timer - refreshTime, 0) & " seconds"
For some reason that I cannot understand, the wq.Delete function will correctly delete the created wq but it will also remove a connection in another sheet which is set up manually as part of the file.
To be clear - it does not DELETE the connection. It is still there but if you look at its properties, and go to the Used In tab, it shows as no longer used in any sheet.
I have no idea why this is happening - for me, the code should clearly delete only the connection in the sheet in the loop and not impact any other connections in the file.
This seems like a fundamental excel bug but I'd really like any input you have because I'm completely stuck.
Appreciate your help!
Based on the comment form #DeanDeVilliers The solution that worked was to reference the table by name. Here is the working code if anyone is curious
Sub WQ_Refresh(wsname As String, wqName As String, wqURL As String, strFC As String)
Dim ws As Worksheet
Dim wq As QueryTable
Dim errno As Long
Dim loopcnt As Integer
Dim refreshTime As Double
Dim lastrow As Long
refreshTime = Timer
Application.StatusBar = "Now downloading " & wqName & " for " & strFC
If wsname = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets(wsname)
If ws.QueryTables.Count > 0 Then ws.QueryTables("WQ_" & wqName).Delete
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lastrow > 1 Then lastrow = lastrow + 1
Set wq = ws.QueryTables.Add(Connection:="URL;" & wqURL, Destination:=ws.Range("A" & lastrow))
errno = 1
loopcnt = 0
Do While Not (errno = 0 And loopcnt < 10)
On Error Resume Next
With wq
.FieldNames = True
.WebFormatting = xlWebFormattingNone
.WebSelectionType = xlAllTables
.Refresh BackgroundQuery:=False
.Name = "WQ_" & wqName
' .Delete
End With
loopcnt = loopcnt + 1
errno = Err.Number
If loopcnt = 10 Then HashtagFail wqName
On Error GoTo 0
ws.QueryTables("WQ_" & wqName).Delete
Loop
If lastrow > 1 Then
ws.Rows(lastrow - 1 & ":" & lastrow).Delete
End If
Set wq = Nothing
Application.StatusBar = "Downloaded " & wqName & " in " & Round(Timer - refreshTime, 0) & " seconds"
End Sub

VBA to Update and Replace in Workbooks causes crashing

Please bear with me. My code is probably complete shit, so I appreciate all feedback! So what this does is, on my main workbook, there are a bunch of UNC hyperlinks in Row M, that link to files in a section drive.
What this code does:
Go down the list of hyperlinks in Column M, opens them up and executes the code inside of the "With WBSsource".
First, it searches for instances of the incorrect filepath (st) inside each of the cells formulas (NOT VALUES), and increments a counter using InStr (t), then after the worksheet has been searched, if the final count (c) is more than 0, meaning the search found at least one incorrect filepath, it will proceed to the next step.
It does a Cells.Replace on a worksheet (ws.) basis (at the FORMULA level)
Cells per worksheet are all done, it should save the workbook and close it before moving onto the next one.
Any links that could not be opened will appear in a final popup.
It is by Step 3 that it starts to run sluggish and crash.
I'm trying my best to get this automated and saving the workbooks. Then, once they're all updated, running this code again would be much faster cause it won't have to replace everything again.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
Dim ws As Worksheet
Dim r As Range, t As Long, c As Integer
' Update the individual credit models
With ThisWorkbook.ActiveSheet
lr = .Cells(.Rows.Count, "M").End(xlUp).Row
FileNames = .Range("M2:M" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
Application.DisplayAlerts = False
ActiveWorkbook.Final = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
st = "\\corp\Accounts\" 'Search Phrase
n = "\\corp\StackOverflow\Accounts\" 'New Phrase
c = 0
For Each ws In WBSsource.Worksheets
ws.Activate
t = 0
On Error Resume Next
For Each r In ws.Cells.SpecialCells(xlCellTypeFormulas)
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
Next r
Next ws
If c > 0 Then
'MsgBox ws.Name & Chr(10) & (c)
ws.Cells.Replace st, n
End If
.UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
'MsgBox "The Following Files Could Not Be Opened" & _
' Chr(10) & msg, 48, "Error"
Set objShell = CreateObject("Wscript.Shell")
objShell.Popup "The Following Files Could Not Be Opened" & _
Chr(10) & Chr(10) & msg, 48, "Error"
End If
Application.DisplayAlerts = True
End Sub
It's not completely crap. I just learned that we could create an array with this.
FileNames = .Range("M2:M" & lr).Value
It may crash since there's no range limit on the 3rd step. Try getting the last row and column on each worksheet, then create a range based on that.
With ws
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For each r in .Range(.Cells(1,1), .Cells(intLastRow, intLastCol))
' Check formula if it contains specific string
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
' Replace formula with new string
r.Formula = Replace(r.Formula, st, n)
Next r
End With
Edit: Here's the full code. Let me know if this works for you.
Option Explicit
' Update the individual credit models
Sub List_UpdateAndSave()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorHandler
' Declaration
Dim i As Long
Dim arrLinks As Variant
Dim strLinksErr As String
' Initialization
Dim strPathCur As String: strPathCur = "\\corp\Accounts\" ' search phrase
Dim strPathNew As String: strPathNew = "\\corp\StackOverflow\Accounts\" ' new phrase
With ThisWorkbook.ActiveSheet
' Get links from sheet
arrLinks = .Range("M2:M" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Value
End With
For i = LBound(arrLinks, 1) To UBound(arrLinks, 1)
' Check for Excel links
If VBA.InStr(1, arrLinks(i, 1), ".xls", vbTextCompare) > 0 Then
FnExcelUpdateLinks arrLinks(i, 1), strPathCur, strPathNew
Else
' Add to list of links that could not be opened
strLinksErr = strLinksErr & arrLinks(i, 1) & Chr(10)
End If
Next i
ErrorHandler:
' Display any errors
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Error " & Err.Number
' Display any non-Excel links
If strLinksErr <> "" Then
MsgBox "The following files could not be opened:" & _
Chr(10) & strLinksErr, 48, "Error"
End If
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function FnExcelUpdateLinks(ByVal strWbkPath As String, ByRef strPathCur As String, ByRef strPathNew As String)
Dim intLastRow As Long, intLastCol As Long
Dim wbkTmp As Workbook
Dim shtTmp As Worksheet
Dim rngCell As Range
' Open link as workbook
Set wbkTmp = Workbooks.Open(strWbkPath, ReadOnly:=False, Password:="", UpdateLinks:=3)
With wbkTmp
For Each shtTmp In .Worksheets
With shtTmp
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For Each rngCell In .Range(.Cells(1, 1), .Cells(intLastRow, intLastCol))
If VBA.InStr(1, rngCell.Formula, strPathCur) > 0 Then
rngCell.Formula = Replace(rngCell.Formula, strPathCur, strPathNew)
End If
Next rngCell
End With
Next shtTmp
.UpdateLink Name:=.LinkSources, Type:=xlExcelLinks
.Save
.Close True
End With
End Function

No data transfer to Access with ADODB recordset

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

Type mismatch error on VBA with empty cells which contain formulas

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

Check whether a specific workbook is open

I have this code so far to transfer between two files. How do I check whether the destination workbook is open? I've tried IsWorkbookOpen(), but it says "function not defined".
Sub Test2()
Dim rowCount As Long
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim a As Integer
a = 1
z = 5
x = 2
y = 16
ActiveWorkbook.Sheets("Results").Activate
rowCount = Cells(Rows.Count, "B").End(xlUp).Row
MsgBox "There are " & Workbooks.Count & " open workbooks!"
For Counter1 = 1 To 8
a = 1
z = 5
MsgBox "From :(" & a & "," & x & ") To:(" & z & "," & y & ")"
For Counter = 1 To rowCount
If IsWorkbookOpen("CMK & CPK Sheet (Rev2)") = True Then
MsgBox "Workbook is Open!"
Else
MsgBox "Workboook is Not Open!"
Workbooks("CMK & CPK Sheet (Rev2)").Sheets(3).Cells(z, y).Value = ActiveWorkbook.ActiveSheet.Cells(a, x).Value
z = z + 1
a = a + 1
Next Counter
y = y + 1
x = x + 1
Next Counter1
End Sub
Here is one way to see if a specific workbook is open:
Sub hfskadjrufc()
Dim bk As Workbook
Dim s As String, ItIsOpen As Boolean
s = "todo.xls"
ItIsOpen = False
For Each bk In Workbooks
If bk.Name = s Then
ItIsOpen = True
End If
Next bk
MsgBox ItIsOpen
End Sub
Try this:
Dim targetWB as Workbook
On Error Resume Next
Set targetWB = Workbooks("CMK & CPK Sheet (Rev2)")
On Error Goto 0
If targetWb Is Nothing Then
MsgBox "Workbook not yet open"
Exit Sub 'you can terminate procedure or you can use Workbooks.Open
Else
MsgBox "Workbook open"
'~~> rest of your code here
End If
Hope this helps.

Resources