I have a Combobox providing data for a "filter" on a subform, once this subform has been filtered I'm using some code to enter the subform and put the data into an array.
I'm noticing that when I have more than 500 rows in my filtered data, getrows stops taking the data. (It's good from 0 to 500). Anything post 500 gives "" for the data.
I've tried increasing the getrows manually (instead of a variable I input like "1000"), and using ubound but I can't seem to get these to work how I would like them to. I assume their functionality isn't what I need.
Dim rstTooling As DAO.Recordset
Dim strToolingHolder() As \
Dim i As
Dim intColumn As Integer, intRow As Integer, intHolder As Integer
Dim varRecords As Variant
i = 0
ReDim strToolingHolder(0)
Set rstTooling = Me.subTooling.Form.Recordset
intHolder = rstTooling.RecordCount
varRecords = rstTooling.GetRows(intHolder)
rstTooling.MoveLast
intHolder = rstTooling.RecordCount
For intColumn = 2 To 2
For intRow = 0 To (intHolder - 1)
strToolingHolder(i) = varRecords(intColumn, intRow)
i = (i + 1)
ReDim Preserve strToolingHolder(i)
Next intRow
Next intColumn
I would ideally like to have varRecords (the getrows function) report back more than 500 data points. Although, if there are other ways that this can be done that may be better suited, I'm open to changing code around.
I'm not sure what you are missing, but this essential code:
Dim rstTooling As DAO.Recordset
Dim intHolder As Long
Dim varRecords As Variant
Set rstTooling = Me.Recordset
rstTooling.MoveLast
intHolder = rstTooling.RecordCount
rstTooling.MoveFirst
varRecords = rstTooling.GetRows(intHolder)
Debug.Print LBound(varRecords, 2), UBound(varRecords, 2)
returns correctly and as expected for a table of 200000 records:
0 199999
Related
I am trying to populate a one column table in excel which I can connect to power query, using vba and a one dimensional array.
So the user puts a list into a textbox where each item is seperated by a semicolon, then it brings that into the array. So far I have :
Dim arrSIOCodes As Variant
arrSIOCodes = Split(tbSIOCodes, ";")
ThisWorkbook.Sheets("CAEATFA_SIO").Activate
Call ChangeTableToArray(tbl:=ThisWorkbook.Sheets("CAEATFA_SIO").ListObjects("tblSIOCodes"), ar:=arrSIOCodes)
and I got this sub from another stack overflow post but I need to customize it to my issue and I am having trouble
Sub ChangeTableToArray(tbl As ListObject, ar)
Dim newRows As Long: newRows = 1 + UBound(ar, 1) - LBound(ar, 1)
If Not tbl.DataBodyRange Is Nothing Then tbl.DataBodyRange.EntireRow.Delete
If newRows > 1 Then tbl.HeaderRowRange.Resize(newRows - 1).Offset(2).EntireRow.Insert
tbl.HeaderRowRange.Resize(newRows, 1 + UBound(ar, 1) - LBound(ar, 1)).Offset (1).value = ar
End Sub
This is what the current code is doing:
however this is what I need it to do:
You are resizing the number of columns in the destination, but you only have one column (if you Transpose the array) to store. So do something like:
tbl.HeaderRowRange.Resize(newRows, 1).Offset (1).value = Application.Transpose(ar)
About to go into a late meeting, so I threw this together quickly and it's untested. But this is just another way to look at it:
Sub ArrayToTable(ByVal ws As Worksheet, ParamArray YourArr() As Variant)
Dim TmpArr As Variant, i As Long, LineNum As Long
TmpArr = YourArr(0)
LineNum = 1 'whatever method you use to find linenumbers
For i = LBound(TmpArr) To UBound(TmpArr)
ws.Cells(LineNum, 1).Value = TmpArr(i)
LineNum = LineNum + 1
Next
End Sub
Before I ask my question, I'm an amateur coder with basically no meaningful experience beyond VBA in ms office apps (I know - noob!)
I'm trying to create a web scraper using VBA to import data into excel and as per my comments in the below extract of code, the best I've been able to find on this is was in the winning answer to this question.
Below, I'm using investing.com as an example but in reality my project will be across multiple sites and will feed into a matrices which will be updating daily and self cannibalizing as events expire - For this reason I'd rather front-up the workload on the code side to make the inputs on an ongoing basis as minimal as possible (for me).
With that in mind, can I ask if there's a way to do any of the following (brace yourself, this will be cringe-worthy basic knowledge for some):
Is there a way in which I can and navigate to a url and run a for each loop on every table on that page (without have a known id for any)? this is to speed up my code as much as it's to minimise my inputs as there'll be quite a bit of data to be updated and I was planning on putting a 2 minute looping trigger on the refresh.
Instead of doing what I've been doing below, is it possible to reference a table, rather than a row, and do something along the lines of Cells(2,5).value to return the value within row 1, column 4? (assuming that both the array indexing starts at 0 in both dimensions?) Further to that, my first column (my primary key in some ways) may not be in the same order on all sources so is there a way in which I could do the equivalent to Columns("A:A").Find(What:=[Primary key], After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Row to find what row within the table relates to the even I'm looking for?
Code :
Sub Scraper()
Dim appIE, allRowOfData As Object
' As per https://stackoverflow.com/questions/27066963/scraping-data-from-website-using-vba
Set appIE = CreateObject("internetexplorer.application")
With appIE
.Navigate "http://uk.investing.com/rates-bonds/financial-futures" 'Sample page
.Visible = False
End With
Do While appIE.Busy
Application.Wait (Now + TimeValue("0:00:01")) 'If page not open, wait a second befor trying again
Loop
Set allRowOfData = appIE.document.getElementById("pair_8907")
'tr id="[ID of row within table]"
Dim myValue As String: myValue = allRowOfData.Cells(8).innerHTML
'The 8 is the column number of the table
'(note: column numbers start at 0 so the 9th column should have "8" entered here
Set appIE = Nothing
Range("A1").Value = myValue
End Sub
If you want to use Excel functions to navigate the tables why not dump the tables first onto a worksheet this code works for me
Option Explicit
Sub Scraper()
Dim appIE As Object
' As per http://stackoverflow.com/questions/27066963/scraping-data-from-website-using-vba
Set appIE = CreateObject("internetexplorer.application")
With appIE
.Navigate "http://uk.investing.com/rates-bonds/financial-futures" 'Sample page
.Visible = True
End With
Do While appIE.Busy
DoEvents
Application.Wait (Now + TimeValue("0:00:01")) 'If page not open, wait a second befor trying again
Loop
'Debug.Print TypeName(appIE.document)
Dim doc As Object 'MSHTML.HTMLDocument
Set doc = appIE.document
'* appIE busy is good but you need to wait for the whole document to completely load and initialise so use this
While doc.readyState <> "complete"
DoEvents
Wend
'* we can select all the tables because they share the same CSS class name
Dim tablesSelectedByClass As Object 'MSHTML.HTMLElementCollection
Set tablesSelectedByClass = doc.getElementsByClassName("genTbl")
'* you can change this, it was just convenient for me to add sheets to my workbook
Dim shNewResults As Excel.Worksheet
Set shNewResults = ThisWorkbook.Worksheets.Add
Dim lRowCursor As Long '* this controls pasting down the sheet
lRowCursor = 1
Dim lTableIndexLoop As Long
For lTableIndexLoop = 0 To tablesSelectedByClass.Length - 1
Dim tableLoop As Object 'MSHTML.HTMLTable
Set tableLoop = tablesSelectedByClass.Item(lTableIndexLoop)
If LenB(tableLoop.ID) > 0 Then '* there are some extra nonsense tables, this subselects
Dim sParentColumn As String, objParentColumn As Object ' MSHTML.HTMLSemanticElement
Set objParentColumn = FindMyColumn(tableLoop, sParentColumn) '* need to understand is table on left hand or right hand side
Dim vHeader As Variant: vHeader = Empty
If sParentColumn = "leftColumn" Then
'* tables on the left have a preceding H3 element with the table's description
Dim objH3Headers As Object
Set objH3Headers = objParentColumn.getElementsByTagName("H3")
vHeader = objH3Headers.Item(lTableIndexLoop).innerText
Else
'* tables on the right have a hidden attribute we can use
vHeader = tableLoop.Attributes.Item("data-gae").Value
If Len(vHeader) > 3 Then
vHeader = Mid$(vHeader, 4)
Mid$(vHeader, 1, 1) = Chr(Asc(Mid$(vHeader, 1, 1)) - 32)
End If
End If
'* tables on the right do not have column headers
Dim bHasColumnHeaders As Boolean
bHasColumnHeaders = (tableLoop.ChildNodes.Length = 2)
Dim vTableCells() As Variant '* this will be our table data container which we will paste in one go
Dim lRowCount As Long: lRowCount = 0
Dim lColumnCount As Long: lColumnCount = 0
Dim lDataHeadersSectionIdx As Long: lDataHeadersSectionIdx = 0
Dim objColumnHeaders As Object: Set objColumnHeaders = Nothing
If bHasColumnHeaders Then
Set objColumnHeaders = tableLoop.ChildNodes.Item(0).ChildNodes.Item(0)
lRowCount = lRowCount + 1
lDataHeadersSectionIdx = 1
Else
lDataHeadersSectionIdx = 0
End If
Dim objDataRows As Object 'MSHTML.HTMLElementCollection
Set objDataRows = tableLoop.ChildNodes.Item(lDataHeadersSectionIdx).ChildNodes
lColumnCount = objDataRows.Item(0).ChildNodes.Length
lRowCount = lRowCount + objDataRows.Length
ReDim vTableCells(1 To lRowCount, 1 To lColumnCount) As Variant
'* we have them get the column headers
Dim lColLoop As Long
If bHasColumnHeaders Then
For lColLoop = 1 To lColumnCount
vTableCells(1, lColLoop) = objColumnHeaders.ChildNodes.Item(lColLoop - 1).innerText
Next
End If
'* get the data cells
Dim lRowLoop As Long
For lRowLoop = 1 To lRowCount - VBA.IIf(bHasColumnHeaders, 1, 0)
For lColLoop = 1 To lColumnCount
vTableCells(lRowLoop + VBA.IIf(bHasColumnHeaders, 1, 0), lColLoop) = objDataRows.Item(lRowLoop - 1).ChildNodes.Item(lColLoop - 1).innerText
Next
Next
'* paste our table description
shNewResults.Cells(lRowCursor, 1).Value2 = vHeader
lRowCursor = lRowCursor + 1
'* paste our table data
shNewResults.Cells(lRowCursor, 1).Resize(lRowCount, lColumnCount).Value2 = vTableCells
lRowCursor = lRowCursor + lRowCount + 1
End If
Next
End Sub
Function FindMyColumn(ByVal node As Object, ByRef psColumn As String) As Object
'* this code ascends the DOM looking for "column" in the id of each node
While InStr(1, node.ID, "column", vbTextCompare) = 0 And Not node.ParentNode Is Nothing
DoEvents
Set node = node.ParentNode
Wend
If InStr(1, node.ID, "column", vbTextCompare) > 0 Then
Set FindMyColumn = node
psColumn = CStr(node.ID)
End If
End Function
By the way, if you trade a lot the brokers get rich and you get poor, brokerage charges really impact in long run.
As the title suggests I am looking into different ways to store the contents of a query into an array. I have been experimenting with different varieties of doing this, but it seems to be that most of these ways are in correct in their output. This is of course do to my lack of understanding of how this is supposed to be appropriately done, so after a while of experimenting I have decided to ask whats the best approach for this? I will share with you some of my approaches thus far and you can see where my investigation has landed me.
Dim MyArray() As Variant
MyArray = rst.GetRows(rst.RecordCount)
This was ok yet this stored all the information vertically instead of horizontally. Is there a way to flip that? Would that be through the use of ReDim? Or is this due to the fact the rows are getting stored in array dimensions and thus they naturally vertical?
Index = 0
Do While Not rst.EOF
ReDim Preserve MyArray(1, Index)
MyArray(0, Index) = CStr(rst.Fields(0).Value)
'Safety check to make sure the value isn't null (was having problems before)
If rst.Fields(1).Value <> vbNullString Then
MyArray(1, Index) = CStr(rst.Fields(1).Value)
End If
Index = Index + 1
rst.MoveNext
Loop
sheet.Range("a1:ba10000").Value = MyArray
This again stored things vertically, but didnt output the records correctly, and in fact only pull the first two columns of info per record, the rest was output as #N/A#. I think I was closer with my original approach, but decided experimenting might land me somewhere.
Do you peeps have some suggestions or can point me in the right direction?
I think it would be quicker to just dump the results to the sheet using:
Sheet1.Range("A1").CopyFromRecordset rst
And then store the results of that dump (from the range) into an array. If it isn't vertical or horizontal like you like, a quick copy/paste-special transpose will make very quick work of it, before bringing it back into the array.
I'm only suggesting that since it seems like your recordset is rather large (2x10000), so iterating as you are doing is going to be time consuming, where dumping the results to the worksheet, manipulating, and picking them back up should be very very quick.
Update (many years later). Looks like it's possible to dump into an array. Something like:
Dim arr
rst.MoveFirst
arr = rst.GetRows
This would allow for programatic manipulation of the recordset (in the array) before shooting the data out to the workbook.
This should work to answer your Question, albeit 5 years late. Recordset to Array to Worksheet
ReDim Preserve can only be used to resize the upperbound of the last previous dimension. You don't have 1 yet, so no ReDim Preserve.
'Goes on Top
Option Explicit
Option Compare Text
Option Base 1
Public Sub Recordset_to_Array_to_Worksheet()
Dim MyArray() As Variant 'unbound Array with no definite dimensions'
Dim db as DAO.Database
Dim rst as DAO.Recordset
Dim strSQL as String, Fieldname as String
Dim i as Integer, j as Integer, colcnt as Integer, rowcnt as Integer
Dim wb as Workbook
Dim ws as Worksheet
Dim Dest as Range
'------------------------RECORDSET------------------------'
Set db = Opendatabase("URL link") 'or Set db = Currentdb()
strSQL = "SQL Statement Here"
Set rst = db.OpenRecordset(strsQL, dbOpenDynaset)
If rst.recordcount <> 0 then '///Do NOT Use "Do While Not rst.EOF" Can cause Problems///'
colcnt = rst.Fields.Count-1
rowcnt = rst.recordcount
Else
Exit Sub
End IF
'-----------------------------WRITE RECORDSET TO MYARRAY----------------------------'
ReDim MyArray (rowcnt, colcnt) 'Redimension MyArray parameters to fit the SQL returned'
rst.MoveFirst
'Populating Array with Headers from Recordset'
For j = 0 To colcnt
MyArray(0,j) = rst.Fields(j).name
Next
'Populating Array with Record Data
For i = 1 to rowcnt
For j = 0 to colcnt
MyArray(i,j) = rst(j)
Next J
rst.movenext
Next i
'---------------------------------WORKSHEET OUTPUT---------------------------------'
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Insert Worksheet Name")
Set Dest = ws.Range("A1") 'Destination Cell
Dest.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).value =
Application.Transpose(MyArray) 'Resize (secret sauce)
End Sub
I have a table structured (Table Name: Table2) like below:
Using VBA, I want to select ONLY a single column value of the current row by iterating over each row.
Here is the code and I wrote:
Function findColumnValue(strColCombIdent As String, strColumnName As String) As String
On Error Resume Next
Dim strRetResult As String
Dim wsMapMasterRefSheet As Worksheet
'Referes to the table Table2.
Dim loMapMaster As ListObject
Set wsMapMasterRefSheet = ThisWorkbook.Worksheets("Sheet3")
Set loMapMaster = wsMapMasterRefSheet.ListObjects("Table2")
'All rows of the table Table2
Dim rAllRows As Range
Set rAllRows = loMapMaster.DataBodyRange
'Holds one row from the databody range for processing.
Dim rCurrRow As Range
'Process data
Dim strTemp As String
For Each rCurrRow In rAllRows
strTemp = rCurrRow.Columns(2)
Debug.Print strTemp
Next rCurrRow
findColumnValue = strRetResult
End Function
I was hoping to get results like below (ONLY the value of the column 2):
1.5
1.5
1.8
4
3
3
1
2
10
12
5
7
Instead I end up with something like this (All values from column#2 onwards, for each processing row.)
1.5
0.045150462962963
1.5
4.52083333333333E-02
1.8
4.72685185185185E-02
4
0.168090277777778
3
3.1
3
8.47800925925926E-02
1
4.16666666666667E-02
2
8.33449074074074E-02
10
10.1.1.1
12
1.3.4.5
5
0.212511574074074
7
8.54166666666667E-02
Using
strTemp = rCurrRow.Columns(1, 2)
instead of
strTemp = rCurrRow.Columns(2)
Causes runtime error 1004
Since each iteration points to a range object in the For loop; I was thinking using
rCurrRow.Columns(2)
will point to current Row's column#2 and hence print out only the column's value.
Is my logic misplaced?
One additional question:
Why does the MSDN Excel Reference guide describes Columns as a Property; where as clearly the "Columns" usage clearly takes parameters
Here is the link I referred:
http://msdn.microsoft.com/en-us/library/office/ff197454(v=office.15).aspx
Either specify you want to iterate rows:
For Each rCurrRow In rAllRows.Rows
or only look at the ListRows in the first place:
Function findColumnValue(strColCombIdent As String, strColumnName As String) As String
On Error Resume Next
Dim strRetResult As String
Dim wsMapMasterRefSheet As Worksheet
'Referes to the table Table2.
Dim loMapMaster As ListObject
Set wsMapMasterRefSheet = ThisWorkbook.Worksheets("Sheet3")
Set loMapMaster = wsMapMasterRefSheet.ListObjects("Table2")
'All rows of the table Table2
Dim rAllRows As ListRows
Set rAllRows = loMapMaster.ListRows
'Holds one row from the databody range for processing.
Dim rCurrRow As ListRow
'Process data
Dim strTemp As String
For Each rCurrRow In rAllRows
strTemp = rCurrRow.Range(, 2)
Debug.Print strTemp
Next rCurrRow
findColumnValue = strRetResult
End Function
You can call your variable rCurrRow all you want; VBA still won't know that you mean for it to contain an entire row of range rAllRows. It just assumes that rCurrRow represents one cell, such that For Each rCurrRow In rAllRows means "for each individual cell in this range".
What you need to do is limit the range being looped through. This should work; not tested.
For Each rCurrRow In rAllRows.Columns(2)
strTemp = rCurrRow
Debug.Print strTemp
Next rCurrRow
In fact I wouldn't call that variable rCurrRow at all; if you're going to use it in this way, call it e.g. cell instead.
EDIT: now that you have clarified your question in a comment below, you could do this:
For i = 1 To rAllRows.Rows.Count
Set rCurrRow = rAllRows.Rows(i)
strTemp = rCurrRow.Cells(1,2)
Debug.Print strTemp
Next i
But even better and faster would be to load the entire range to a two-dimensional Variant array at once, and loop over that array — much faster than looping over many cells.
Dim v As Variant
v = rAllRows ' load entire range to a 2D array
For i = 1 To UBound(v,1)
strTemp = v(i,2)
Debug.Print strTemp
Next i
Why does the MSDN Excel Reference guide describes Columns as a Property; where as clearly the "Columns" usage clearly takes parameters
Both methods and properties can take parameters. The distinction is more or less as follows:
Properties are things that you can get (like a range's Address, which takes no parameter, or subrange such as Column or Row or Cells, which do) and/or set (like a range's .Interior.Color, or .Hidden status). They are usually nouns.
Methods are things that do something to/with the range, and as such are usually verbs. Like .Select (takes no parameters) or .Copy (takes one parameter) or even .Speak.
I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.