I have a RecordSet loop inside another RecordSet loop. It'd work well if it didn't take 45 secs for the .OpenRecordSet to run, and the table it'll open has 445k registers.
The reason for the inside loop is because I need to filter results obtained from another RecordSet, and then get these new results and compare.
Would it be better to use other methods, or other way? Is there another way to get specific data from a table(a faster way, of course)? Should I try multithreading?
Since people might need my code:
Private Sub btnGetQ_Click()
Dim tabEQ As DAO.Recordset: Dim tabT7 As DAO.Recordset: Dim tabPesqC As DAO.Recordset: Dim PesqCqdf As DAO.QueryDef
Dim index As Integer: Dim qtdL As Long: Dim qtdL2 As Long
Dim arrC() As String: Dim arrC2() As String: Dim arrC3() As String
Set tabEQ = dbC.OpenRecordset("EQuery", dbOpenSnapshot)
Set tabT7 = dbC.OpenRecordset("T7Query", dbOpenSnapshot)
If Not tabEQ.EOF Then
tabEQ.MoveFirst
qtdL = tabEQ.RecordCount - 1
ReDim arrC(qtdL): ReDim arrC2(qtdL)
If Not tabT7.EOF Then
tabT7.MoveFirst: index = 0
Do Until tabT7.EOF
arrC(index) = tabT7.Fields("CCO"): arrC2(index) = tabT7.Fields("CCE")
Set PesqCqdf = dbC.QueryDefs("pesqCCO")
PesqCqdf.Parameters("CCO") = arrC(index)
Set tabPesqC = PesqCqdf.OpenRecordset(dbOpenSnapshot)
qtdL2 = tabPesqConj.RecordCount - 1
If qtdL2 > 0 Then
ReDim arrC3(qtdL2)
Dim i As Integer
For i = 0 To UBound(arrC3)
arrC3(i) = tabPesqC.Fields("CCE")
tabPesqC.MoveNext
Next
End If
On Error GoTo ERROR_TabT7
index = index + 1: tabT7.MoveNext
Loop
End If
ERROR_TabT7:
Set tabT7 = Nothing
End If
If IsObject(tabEQ) Then Set tabEQ = Nothing
End Sub
I created tables linked with what i wanted :/
Related
I'm running a VBA for each loop through an Excel table (Listobject) which checks if a file exists based on a given path. My table has expanded though and has 68K Listrows. After launching the code, it quickly gives an error Run-time-error '7': Out of memory
It runs OK with 63K lines (done within 5 minutes) and based on googling there appears to be something called "64K segment boundary". Is this what's affecting my code to run since it really feels like it buffers the row count at first and then bounces back w/o starting to actually run anything. Is there an easy workaround for this without the need to split up my dataset into multiple batches? Frankly, I was quite surprised that 64K limits would still be a thing in Excel in 2021.
Running it on 64bit Excel 2019, but no luck with Office365 either.
Sub CheckFiles()
Dim Headers As ListObject
Dim lstrw As ListRow
Dim strFileName As String
Dim strFileExists As String
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Import")
Set Headers = ws.ListObjects("Import")
For Each lstrw In Headers.ListRows
strFileName = lstrw.Range(7)
strFileExists = Dir(strFileName)
If strFileExists = "" Then
lstrw.Range(4) = "not found"
Else
lstrw.Range(4) = "exists"
End If
Next lstrw
Set ws = Nothing
Set Headers = Nothing
Application.ScreenUpdating = True
End Sub
Avoid Accessing the Worksheet
Since you cannot avoid looping, you better do it in the computer's memory, i.e. rather through the elements of an array than through the cells of a range.
The code is still slow, about 10s for 200k rows on my machine, but that's because of Dir.
Note how easy (one line only, when the range contains more than one cell) and how fast (a split second) it is to write (copy) a range to an array (Data = rg.Value) and write (copy) the array back to a range (rg.Value = Data).
Adjust the values in the constants section.
Option Explicit
Sub CheckFiles()
Const wsName As String = "Import" ' Worksheet Name
Const tblName As String = "Import" ' Table Name
Const cCol As Long = 7 ' Criteria Column
Const dCol As Long = 4 ' Destination Column
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim Headers As ListObject: Set Headers = ws.ListObjects(tblName)
Dim Data As Variant ' Data Array
With Headers.ListColumns(cCol).DataBodyRange
If .Rows.Count = 1 Then
ReDim Data(1 To 1, 1 To 1): Data = .Value
Else
Data = .Value
End If
End With
Dim r As Long ' Array Row Counter (DataBodyRange Row Counter)
Dim FileName As String ' File Name Retrieved by Dir
For r = 1 To UBound(Data, 1)
FileName = Dir(CStr(Data(r, 1)))
If Len(FileName) = 0 Then
Data(r, 1) = "not found"
Else
Data(r, 1) = "exists"
End If
Next r
Headers.ListColumns(dCol).DataBodyRange.Value = Data
End Sub
Thank you all! A few takeaways. While obviously trying to write as efficient code as possible, any reasonable performance here is acceptable. With that said, for each loop took approx 5 minutes to run with 63K lines, meawhile it was done in about 15 seconds by the code I accepted as an answer by #VBasic2008 - without capacity problems either.
The only problem I had with this particular code was it being somewhat new approach for me, so possibly building on it in the future needs some dedication in looking deeper into it - but it sure looks efficient. I also put together a regular for ... to loop which also didn't run into problems with 68K lines and would steer between rows and columns with offset function.
Clearly faster than for each as #Pᴇʜ suggested but took approx 2x as long as the array method (30 seconds or so).
Sub CheckFiles_2()
Dim strFileName, strFileExists As String
Dim ws As Worksheet
Dim Headers As ListObject
Dim result As String
Dim counter, RowCount As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Import")
Set Headers = ws.ListObjects("Import")
RowCount = Headers.ListRows.Count
For counter = 1 To RowCount
strFileName = Range("anchorCell").Offset(counter, 3)
strFileExists = Dir(strFileName)
If strFileExists = "" Then
result = "not found"
Else
result = "exists"
End If
Range("anchorCell").Offset(counter, 0) = result
Next counter
Set ws = Nothing
Set Headers = Nothing
Application.ScreenUpdating = True
End Sub
I dont work with VBA much, I have a number of global integer variables, such as DFromRow1, DFromRow2, DFromRow3 up until DFromRow20. I want to set each of these in sequential order in this manner(This is just a very simple example to help you understand what I am trying to do) :
Dim Count as integer
Count = 0
Begin Loop(loop here for 20 times)
Count = Count + 1
DFromRow & Count = Count
End Loop
The idea here is that the global variables will be populated as such:
DFromRow1 = 1
DFromRow2 = 2
DFromRow3 = 3
... up until 20
However I get an error on the & :
Expected: expression
Is there a way to do this or am I being too ambitious with what I want ?
Thanks appreciate any help.
Instead of declaring 20 variables DFromRow you can use array
Something like this
Option Explicit
Public ArrDFromRow(20)
Sub Test()
Dim i As Long
For i = 1 To 20
ArrDFromRow(i) = i
Next i
For i = 1 To 20
Debug.Print ArrDFromRow(i)
Next i
End Sub
You can use an Array to store your values like this:
Dim DRowArray(1 to 20) as Long
Sub PopulateDFromRowArray()
Dim i as Integer
For i = LBound(DRowArray) to UBound(DRowArray)
DRowArray(i) = i
Next
End Sub
Or a Dictionary, albeit you need to set a VBA reference to Microsoft Scripting Runtime:
Dim DRowDict as Scripting.Dictionary
Sub PopulateDFromRowDictionary()
Dim i as Integer
Set DRowDict = New Scripting.Dictionary
For i = 1 To 20
DRowDict.Add "DFromRow" & i, i
Next
End Sub
I need to classify each row of a range accordingly with another range. The script works just fine. But it takes too much time even if it has no more than 300 rows. E.g. 298 rows take more than 2 minutes.
In order to achieve the classification, the script was built with a for each loop inside another one. All is done in the same worksheet called WSSeg. I tried to use all the good practices that I know of.
Option Explicit
Sub Input_Classification()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim TBLClassification As ListObject
Dim TBLReference As ListObject
Dim rClassificationCell As Range
Dim rClassification As Range
Dim rReferenceCell As Range
Dim rReference As Range
Set TBLClassification = WSSeg.ListObjects("TBClass")
Set rClassification = TBL.ListColumns(4).DataBodyRange
Set TBLReference = WSSeg.ListObjects("TBResumo")
Set rReference = TBL.ListColumns(4).DataBodyRange
For Each rClassificationCell In rClassification
For Each rReferenceCell In rReference
If rClassificationCell.Offset(0, -1).Value <= rReferenceCell.Value Then
rClassificationCell.Value = rReferenceCell.Value
End If
Next rReferenceCell
Next rClassificationCell
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I expect the run time code to be shorter. I don't know if I have to use another logic system. Thanks in advance.
Tried to modify the code, it takes only 0.04 Secs with two tables of around 500 rows.
Tried to keep the replacement logic same as the original, But may please check the same, as i am little confused about the same. If find otherwise, please modify them to your need. Also Could not understand the what is TBL in cases with both the tables and assumed the obvious.
Option Explicit
Sub Input_Classification()
Dim WSSeg As Worksheet
Dim TBLClassification As ListObject
Dim TBLReference As ListObject
Dim rClassification As Range
Dim SrcArr As Variant, TrgArr As Variant, SrcCel As Variant
Dim i As Long, Tm As Double
Set WSSeg = ThisWorkbook.Sheets("Sheet1")
Tm = Timer
Set TBLClassification = WSSeg.ListObjects("TBClass")
Set rClassification = TBLClassification.ListColumns(3).DataBodyRange.Resize(TBLClassification.DataBodyRange.Rows.Count, 2)
TrgArr = rClassification.Value
Set TBLReference = WSSeg.ListObjects("TBResumo")
SrcArr = TBLReference.ListColumns(4).DataBodyRange.Value
For i = 1 To UBound(TrgArr, 1)
For Each SrcCel In SrcArr
If TrgArr(i, 1) <= SrcCel Then
TrgArr(i, 2) = SrcCel
End If
Next SrcCel
Next i
rClassification.Value = TrgArr
Debug.Print "Seconds taken " & Timer - Tm
End Sub
Since I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques, depending on the working file condition.
I have created some code to populate combo boxes on my form from a excel file when the form loads.
As part of the code, it is supposed to release the objects associated but it does not
Dim excel As New Excel.Application
Dim w As Excel.Workbook = excel.Workbooks.Open("C:\Email Template\Violations Log\Violations Log.xlsx")
Dim sheet As Excel.Worksheet = w.Worksheets("Individual Data")
Dim r As Excel.Range = sheet.Range("A2:A300")
Dim array(,) As Object = r.Value(excel.XlRangeValueDataType.xlRangeValueDefault)
Dim sheet2 As Excel.Worksheet = w.Worksheets("Category")
Dim s As Excel.Range = sheet2.Range("A2:A20")
Dim array2(,) As Object = s.Value(excel.XlRangeValueDataType.xlRangeValueDefault)
Dim bound0 As Integer = array.GetUpperBound(0)
Dim bound1 As Integer = array.GetUpperBound(1)
Dim j As Integer
Dim x As Integer
Dim s1 As String
If array IsNot Nothing Then
' Loop over all elements.
For j = 1 To bound0
For x = 1 To bound1
s1 = array(j, x)
If s1 IsNot Nothing Then
If Not ComboBox1.Items.Contains(s1.ToString) Then
ComboBox1.Items.Add(s1.ToString)
End If
End If
Next
Next
End If
If array IsNot Nothing Then
' Loop over all elements.
For j = 1 To bound0
For x = 1 To bound1
s1 = array2(j, x)
If s1 IsNot Nothing Then
If Not ComboBox2.Items.Contains(s1.ToString) Then
ComboBox2.Items.Add(s1.ToString)
End If
End If
Next
Next
End If
w.Close(False)
excel.Quit()
ReleaseObject(excel.XlRangeValueDataType.xlRangeValueDefault)
ReleaseObject(excel)
ReleaseObject(array)
ReleaseObject(array2)
ReleaseObject(r)
ReleaseObject(s)
ReleaseObject(sheet)
ReleaseObject(sheet2)
ReleaseObject(w)
ReleaseObject(bound0)
ReleaseObject(bound1)
ReleaseObject(j)
ReleaseObject(x)
ReleaseObject(s1)
Ive tried to release every object that is referenced but it still has a connection to the excel document.
Have I missed an object? or something bigger?
I have another code that copies from the form to that same excel document and that does not leave any processes open. (I have to kill the excel process that is created from loading the form to be able to use the code to copy data)
Any help would be greatly appreciated.
Figured it out.
The code would stop running and not complete the release object section of the code.
Using debugging I found that I was getting an error message which was muted. I resolved the error message and now it runs fine.
Thanks for trying to help.
I'm new to VBA. I'm trying to write a script that cleans up some data from an experiment. I keep getting an error saying "Object Required" and it highlights pold. Does anyone have any idea why?
As for the script, I'm trying to go down a column of participant numbers and map out what range each participant is in. There are around 30 lines per participant, and I want to define that as values in an array.
Sub Cleanthismofoup()
Dim pranges(1 To 50) As Long
Dim pbegin As Range
Dim pend As Range
Dim pold As Integer
Dim pnew As Integer
Dim pcell As Range
Dim pcounter As Long
Dim i As Long
Set pcell = Range("A1:A1")
Set pbegin = Range("A2:A2")
Set pold = Range("B2:B2").Value
pcounter = 0
'for every item, store value in pnew
' move down one line. Check pnew = pold
' if it is, do again. else create new range
For i = 1 To rngl
pcell = pcell.Offset(-1, 0)
pnew = pcell.Cells.Value
If pnnew <> pold Then pcell = pend
If pcell = pend Then
counter = counter + 1
pranges(counter) = pbegin
counter = counter + 1
pranges(counter) = pend
pbegin = pcell.Offset(-1, 0)
Else: pold = pnew
End If
i = i + 1
Next
End Sub
The error is because you are using a Set keyword which is used to assign reference to the object. Since the output on the RHS of Set pold = Range("B2:B2").Value is an Integer, vba gives you an error. To resolve it simply remove the Set keyword. However I also noticed that you are using rng1 in the for loop without initializing the rng1 variable, in which case your for loop will never execute. You might also want to rectify that.