I am receiving a run-time error '91': object variable or with block variable not set whenever I try to run my code below. This code works perfect when extracting the data off of the commented out website I have listed in the code. However, when I try to use it on the google finance site I get that error. Can anyone see what I am doing wrong? I am using the following VBA:
Sub test()
Dim oDom As Object: Set oDom = CreateObject("htmlFile")
Dim x As Long, y As Long
Dim oRow As Object, oCell As Object
Dim data
y = 1: x = 1
With CreateObject("msxml2.xmlhttp")
'http://www.bundesbank.de/Navigation/EN/Statistics/Time_series_databases/Macro_economic_time_series/its_details_value_node.html?tsId=BBNZ1.Q.DE.Y.G.0000.A&listId=www_s311_b4_vgr_verw_nominal
.Open "GET", "http://finance.yahoo.com/q/hp?s=GOOG+Historical+Prices", False
.Send
oDom.body.innerHtml = .responseText
End With
With oDom.getElementsByTagName("table")(0)
ReDim data(1 To .Rows.Length, 1 To .Rows(1).Cells.Length)
For Each oRow In .Rows
For Each oCell In oRow.Cells
data(x, y) = oCell.innerText
y = y + 1
Next oCell
y = 1
x = x + 1
Next oRow
End With
Sheets(1).Cells(1, 1).Resize(UBound(data), UBound(data, 2)).Value = data
End Sub
There are more than 1 table tag in the view source. I had to change,
oDom.getElementsByTagName("table")(0)
' to
oDom.getElementsByTagName("table")(14)
... to have it use the correct table tag.
Related
I have written the following code which is supposed to run through a data set and delete all rows that do not match the value in call C1. In my original code I deleted line by line and the code was very slow, so now I am trying to add all values to a variant and delete all cells at the end. Is this possible?
Sub FixData()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsData2 As Worksheet
Dim FrRngCount As Range
Dim x As Long
Dim y As Long
Dim varRows As Variant
Set wbFeeReport = ThisWorkbook
Set wsData = wbFeeReport.Worksheets("Data")
Set wsData2 = wbFeeReport.Worksheets("Data2")
Set FrRngCount = wsData.Range("D:D")
y = Application.WorksheetFunction.CountA(FrRngCount)
For x = y To 2 Step -1
If wsData.Range("J" & x).Value <> wsData2.Range("C1").Value Then
varRows = x
Else
wsData.Range("AF" & x).Value = wsData.Range("J" & x).Value
End If
Next x
wsData.Rows(varRows).EntireRow.Delete
End Sub
Right now the code only deletes the last row as the variant is overwritten each time as it runs through the loop. Any suggestions on how I can store all values in the variant and delete the rows I don't need at the end?
Thanks for you help!
The fastest way is to
Load the data into an array
Copy the valid data into a second array
Clear the contents of the range
Write the second array back to the worksheet
Sub FixData()
Dim Source As Range
Dim Data, Data1, TargetValue
Dim x As Long, x1 As Long, y As Long
Set Source = Worksheets("Data").Range("A1").CurrentRegion
TargetValue = Worksheets("Data2").Range("C1")
Data = Source.Value
ReDim Data1(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 1 To UBound(Data, 1)
If x = 1 Or Data(x, 10) = TargetValue Then
x1 = x1 + 1
For y = 1 To UBound(Data, 2)
Data1(x1, y) = Data(x, y)
Next
End If
Next
Source.ClearContents
Source.Resize(x1).Value = Data1
End Sub
As you need a range holding all rows, you can collect it in one "on the run" like this:
Sub FixData()
Dim wsData As Worksheet
wsData = ThisWorkbook.Worksheets("Data")
Dim val As Variant
val = ThisWorkbook.Worksheets("Data2").Range("C1").Value
Dim DelRows As Range, x As Long
For x = 2 To wsData.Cells(wsData.Rows.Count, 4).End(xlUp).Row
If wsData.Range("J" & x).Value <> val Then
If DelRows Is Nothing Then
Set DelRows = wsData.Rows(x)
Else
Set DelRows = Union(wsData.Rows(x), DelRows)
End If
Else
wsData.Range("AF" & x).Value = wsData.Range("J" & x).Value
End If
Next x
DelRows.EntireRow.Delete
End Sub
I had this project in Chemistry to supply a list of Compound elements
now I had found a website where it gives me a very long list of elements:
I had made this Code but it Doesn't Work
Sub move()
Dim list As Range
Set list = Range("A1:A2651")
For Each Row In list.Rows
If (Row.Font.Regular) Then
Row.Cells(1).Offset(-2, 1) = Row.Cells(1)
End If
Next Row
End Sub
Can you make it run for me? you can have your own algorithm ofc.
Assuming the list is constantly in the same format (i.e. Compound name, empty line, Compound Symbols, empty line) this quick code will work:
Sub move()
Dim x As Integer
x = 3
With ActiveSheet
Do Until x > 2651
.Cells(x - 2, 2).Value = .Cells(x, 1).Value
.Cells(x, 1).ClearContents
x = x + 4
Loop
End With
End Sub
After running you can then just sort columns A:B to remove the blanks.
After trying your original code I realised the problem was with the .regular property value. I've not seen .regular before, so swapped it to NOT .bold instead, and to ignore blank entries, then added the line for clearing the contents of the cell copied. This is most like the original code for reference:
Sub get_a_move_on()
Dim list As Range
Set list = ActiveSheet.Range("A1:A2561")
For Each Row In list.Rows
If Row.Font.Bold = False And Row.Value <> "" Then
Row.Cells(1).Offset(-2, 1) = Row.Cells(1)
Row.Cells(1).ClearContents
End If
Next Row
End Sub
P.S it's a list of compounds, not elements, there's only about 120 elements in the periodic table! ;)
Another way to retrieve the data you need via XHR and RegEx:
Sub GetChemicalCompoundsNames()
Dim sRespText As String
Dim aResult() As String
Dim i As Long
' retrieve HTML content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://quizlet.com/18087424", False
.Send
sRespText = .responseText
End With
' regular expression for rows
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "qWord[^>]*?>([\s\S]*?)<[\s\S]*?qDef[^>]*?>([\s\S]*?)<"
With .Execute(sRespText)
ReDim aResult(1 To .Count, 1 To 2)
For i = 1 To .Count
With .Item(i - 1)
aResult(i, 1) = .SubMatches(0)
aResult(i, 2) = .SubMatches(1)
End With
Next
End With
End With
' output to the 1st sheet
With Sheets(1)
.Cells.Delete
Output .Range("A1"), aResult
End With
End Sub
Sub Output(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1 _
)
.NumberFormat = "#"
.Value = aCells
.Columns.AutoFit
End With
End With
End Sub
Gives output (663 rows total):
I'm working with a rather large dataset (>100,000 rows) and trying to compare two lists to figure out which items in the new list are not already in the master list. In other words I want to find the new unique items.
I have some VBA code that uses vlookup and arrays that works, but bombs out when the arrays get too big (~70,000). So I've turned to collections. However I'm having difficulty searching the collections using vlookup or match.
Sub find_uniqueIDs()
Dim a As Long
Dim n As Long
Dim m As Variant
Dim oldnum As Long
Dim oldIDs As Variant
Dim oldcoll As New Collection
Dim newnum As Long
Dim newIDs As Variant
Dim newcoll As New Collection
oldnum = 75000
oldIDs = Range("A1", Range("A" & oldnum))
newnum = 45000 + 3
newIDs = Range("G3", Range("G" & newnum))
'Using arrays to search, but bombs out when oldnum or newnum are ~70000
For n = 1 To newnum - 3
m = Application.VLookup(newIDs(n, 1), oldIDs, 1, False)
If IsError(m) Then Range("E100000").End(xlUp).Offset(1, 0) = newIDs(n, 1)
Next n
'Using collections to search
For n = 1 To oldnum
On Error Resume Next
oldcoll.Add oldIDs(n, 1)
On Error GoTo 0
Next n
For m = 1 To newnum
On Error Resume Next
newcoll.Add newIDs(m, 1)
On Error GoTo 0
Next m
'This bit of code doesn't work
For a = 1 To newcoll.Count
If Application.VLookup(newcoll(a), oldcoll, 1, False) = "#N/A" Then _
Range("E100000").End(xlUp).Offset(1, 0) = newcoll(a)
Next a
End Sub
Any ideas how I can determine whether a particular item is in the master list using collections?
Here is a short sub demonstrating some of the scripting dictionary methods.
Sub list_New_Unique()
Dim dMASTER As Object, dNEW As Object, k As Variant
Dim v As Long, vVALs() As Variant, vNEWs() As Variant
Debug.Print "Start: " & Timer
Set dMASTER = CreateObject("Scripting.Dictionary")
Set dNEW = CreateObject("Scripting.Dictionary")
dMASTER.comparemode = vbTextCompare
dNEW.comparemode = vbTextCompare
With Worksheets("Sheet7")
vVALs = .Range("A2:A100000").Value2
vNEWs = .Range("C2:C100000").Value2
End With
'populate the dMASTER values
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
dMASTER.Add Key:=vVALs(v, 1), Item:=vVALs(v, 1)
Next v
'only populate dNEW with items not found in dMASTER
For v = LBound(vNEWs, 1) To UBound(vNEWs, 1)
If Not dMASTER.exists(vNEWs(v, 1)) Then
If Not dNEW.exists(vNEWs(v, 1)) Then _
dNEW.Add Key:=vNEWs(v, 1), Item:=vNEWs(v, 1)
End If
Next v
Debug.Print dNEW.Count
For Each k In dNEW.keys
'Debug.Print k
Next k
Debug.Print "End: " & Timer
dNEW.RemoveAll: Set dNEW = Nothing
dMASTER.RemoveAll: Set dMASTER = Nothing
End Sub
With 99,999 unique entries in A2:A100000 and 89747 random entries in C2:C89747, this found 70,087 unique new entries not found in A2:A100000 in 9.87 seconds.
I would do it like this:
Sub test()
Dim newRow As Long, oldRow As Long
Dim x As Long, Dim y As Long
Dim checker As Boolean
With ActiveSheet
newRow = .Cells(.Rows.Count,7).End(xlUp).Row
oldRow = .Cells(.Rows.Count,1).End(xlUp).Row
checker = True
for y = 1 To oldRow
for x = 1 To newRow
If .Cells(y,1).Value = .Cells(x,7).Value Then
checker = False
Exit For
End If
Next
If checker Then
Range("E10000").End(xlUp).Offset(1,0).Value = .Cells(y,1).Value
End If
checker = True
Next
End With
End Sub
VLookup is a worksheet function, not a regular VBA function, thus it's for searching in Ranges, not Collections.
Syntax: VLOOKUP (lookup_value, table_array, col_index_num, [range_lookup])
[...]
table_array (required): the range of cells in which the VLOOKUP will search for the lookup_value and the return value.
In order to search in other VBA data structures like arrays, collections etc you'll have to figure out some other way and maybe implement it manually.
While #Jeeped suggestion of a Scripting.Dictionary object might be the best one, you could also try using the Filter() function applied to your array.
I need to pull the unique names from column A on Sheet1 and on Sheet2 display only one of each name and the number of times it appeared. The names on Sheet 1 change daily, so I can't hard code any of them in.
Sheet1:
A
Joe
Joe
Paul
Steve
Steve
Steve
Sheet2:
A B
Joe 2
Paul 1
Steve 3
Code I have so far:
Sub testing()
Dim data As Variant, temp As Variant
Dim obj As Object
Dim i As Long
Set obj = CreateObject("scripting.dictionary")
data = Selection
For i = 1 To UBound(data)
obj(data(i, 1) & "") = ""
Next
temp = obj.keys
Selection.ClearContents
Selection(1, 1).Resize(obj.count, 1) = Application.Transpose(temp)
End Sub
However, this is producing an error by itself.
It's giving me:
Joe
Joe
Paul
Steve
Consider using .RemoveDuplicates:
Sub CountUniques()
Dim r1 As Range, r2 As Range, r As Range
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Set r1 = Sheets("Sheet1").Columns(1).Cells
Set r2 = Sheets("Sheet2").Range("A1")
r1.Copy r2
r2.EntireColumn.RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In r2.EntireColumn.Cells
v = r.Value
If v = "" Then Exit Sub
r.Offset(0, 1).Value = wf.CountIf(r1, v)
Next r
End Sub
I wouldn't use a dictionary, personally, I'd do something like this -
Sub countem()
Dim origin As Worksheet
Set origin = Sheets("Sheet1")
Dim destination As Worksheet
Set destination = Sheets("Sheet2")
Dim x As Integer
x = origin.Cells(Rows.Count, "A").End(xlUp).Row
Dim y As Integer
y = 1
Dim strName As String
Dim rngSearch As Range
For i = 1 To x
strName = origin.Cells(i, 1).Value
Set rngSearch = destination.Range("A:A").Find(strName, , xlValues, xlWhole)
If Not rngSearch Is Nothing Then
rngSearch.Offset(, 1) = rngSearch.Offset(, 1) + 1
Else: destination.Cells(y, 1) = strName
destination.Cells(y, 2) = 1
y = y + 1
End If
Next
End Sub
Just run through the origin searching for it on the destination, if found count++, otherwise add it.
A more verbose answer if you insisted on using the dictionary object and if perhaps you had more data processing to do.
' Create Reference to Microsoft Scripting Runtime
' In VBE -> Tools -> References -> Microsoft Scripting Runtime
Option Explicit
Public Sub UniqueItems()
Dim rngInput As Range, rngOutput As Range
Dim vUniqueList As Variant
Set rngInput = ThisWorkbook.Worksheets(1).Range("A:A")
Set rngOutput = ThisWorkbook.Worksheets(2).Range("A:B")
vUniqueList = GetUniqueItems(rngInput)
rngOutput.ClearContents
rngOutput.Resize(UBound(vUniqueList, 1), UBound(vUniqueList, 2)).Value = vUniqueList
End Sub
Private Function GetUniqueItems(vList As Variant) As Variant
Dim sKey As String
Dim vItem As Variant
Dim oDict As Dictionary
If IsObject(vList) Then vList = vList.Value
Set oDict = New Dictionary
For Each vItem In vList
sKey = Trim$(vItem)
If sKey = vbNullString Then Exit For
AddToCountDict oDict, sKey
Next vItem
GetUniqueItems = GetDictData(oDict)
End Function
Private Sub AddToCountDict(oDict As Dictionary, sKey As String)
Dim iCount As Integer
If oDict.Exists(sKey) Then
iCount = CInt(oDict.Item(sKey))
oDict.Remove (sKey)
End If
oDict.Add sKey, iCount + 1
End Sub
Private Function GetDictData(oDict As Dictionary) As Variant
Dim i As Integer
Dim vData As Variant
If oDict.Count > 0 Then
ReDim vData(1 To oDict.Count, 1 To 2)
For i = 1 To oDict.Count
vData(i, 1) = oDict.Keys(i - 1)
vData(i, 2) = oDict.Items(i - 1)
Next i
Else
'return empty array on fail
ReDim vData(1 To 1, 1 To 2)
End If
GetDictData = vData
End Function
Gary's Students solution definitely cleaner!
I need to constantly update excel file with information, obtained from the following link (warning, ukrainian language):
link to the Ministry of Finance web-site of Ukraine
Useful data is wrapped by the HTML tags <tbody></tbody>.
I need the similar code that retrieves the information from the table
Set htm = CreateObject("htmlFile")' #it doesn't work on mac os machine, but perfectly performs on windows
With CreateObject("msxml2.xmlhttp")
.Open "GET", <site_url_goes_here>, False
.send
htm.body.innerhtml = .responsetext
End With
With htm.getelementbyid("item")' <<<<<---what should I write here in order to parse data from the web-site table?
Sheet2.Cells(Row, 4).Value = p
For x = 1 To .Rows.Length - 1
For y = 0 To .Rows(x).Cells.Length - 1
Sheet2.Cells(Row, y + 1).Value = .Rows(x).Cells(y).innertext
Next y
Row = Row + 1
Next x
End With`
Below code will get the updated data from http://www.minfin.gov.ua in every 60 seconds.
Sub getData()
Application.OnTime Now + TimeSerial(0, 0, 60), "finance_data"
End Sub
Private Sub finance_data()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object
Dim tbl As Object, obj_tbl As Object
Dim TR As Object, TD As Object
Dim row As Long, col As Long
lastRow = Range("A" & Rows.Count).End(xlUp).row
url = "http://www.minfin.gov.ua/control/uk/publish/article?art_id=384069&cat_id=234036" & "&r=" & WorksheetFunction.RandBetween(1, 10000)
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.setRequestHeader "Content-Type", "text/xml"
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.ResponseText
Set obj_tbl = html.getelementsbytagname("table")
row = 1
col = 1
For Each tbl In obj_tbl
If tbl.classname = "MsoNormalTable" Then
Set TR = tbl.getelementsbytagname("TR")
For Each obj_row In TR
For Each TD In obj_row.getelementsbytagname("TD")
Cells(row, col) = TD.innerText
col = col + 1
Next
col = 1 ' reseting the value
row = row + 1
Next
End If
Next
getData
End Sub