I want to extract two values (numbers and positions) per player which have an equal class name "text". I am currently unable to select the two correct values per player.
My problem is I actually have only the first and the second value in "HTMLnumbers" and "HTMLposition". Otherwise if I select all items for the class "text", the first player gets the value for number and the second player gets the value for position. Thats also not correct.
Option Explicit
Sub erweiterteWerte()
Dim IE As New SHDocVw.InternetExplorer
Dim HTMLdoc As MSHTML.HTMLDocument
Dim HTMLplayerRow As MSHTML.IHTMLElementCollection
Dim i As Integer
Dim j As Integer
Dim HTMLnumbers As Object
Dim HTMLposition As Object
Dim numbers As String
Dim position As String
Dim letzteZeile As Long
Dim aktuelleZeile As Long
IE.Visible = False
IE.Navigate "https://examplexyz.de"
Do While IE.ReadyState <> READYSTATE_COMPLETE
Loop
Application.Wait (Now + TimeValue("0:00:7"))
Set HTMLdoc = IE.Document
Set HTMLplayerRow = HTMLdoc.getElementsByClassName("playerRow")
Set HTMLnumbers = HTMLplayerRow(0).getElementsByClassName("text")
If Not HTMLnumbers Is Nothing Then
numbers = HTMLnumbers.Item(0).innerText
position = HTMLnumbers.Item(1).innerText
Else
numbers = "no_value"
End If
Debug.Print numbers
Debug.Print position
IE.Quit
End Sub
Untested, but to illustrate the basic approach:
Sub erweiterteWerte()
Dim IE As SHDocVw.InternetExplorer
Dim HTMLdoc As MSHTML.HTMLDocument
Dim playerRows As MSHTML.IHTMLElementCollection
Dim playerBadges As MSHTML.IHTMLElementCollection
Dim player As Object, badge As Object
Set IE = New SHDocVw.InternetExplorer
IE.Visible = False
IE.Navigate "https://play.kickbase.com/transfermarkt/kaufen"
Do While IE.ReadyState <> READYSTATE_COMPLETE
Loop
Application.Wait (Now + TimeValue("0:00:07"))
Set HTMLdoc = IE.Document
Set playerRows = HTMLdoc.getElementsByClassName("playerRow")
For Each player In playerRows
Debug.Print "---------------"
Debug.Print classText(player, "firstName") & " " & classText(player, "lastName")
Set playerBadges = player.getElementsByClassName("badge")
For Each badge In playerBadges
Debug.Print badge.innerText
Next badge
Next player
IE.Quit
End Sub
'Helper function to get a child (of `obj`) element's text using its className
' (only handles a single instance but could be extended)
Function classText(obj As Object, classname As String) As String
Dim els As Object
Set els = obj.getElementsByClassName(classname)
If els.Length > 0 Then
classText = els(0).innerText
Else
classText = "[not found]"
End If
End Function
Related
Assigning word document lines of text to an array to then print into an excel column. I want to print each item in array to it's own cell.
Currently, all the items are storying correctly into the array, but it's only printing the first item over and over Action
Code:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
Dim i As Long
i = 0
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
ReDim Preserve arr(i)
arr(i) = wPara.Range
End If
i = i + 1
Next wPara
For i = LBound(arr) To UBound(arr)
[a1].Resize(UBound(arr) + 1) = arr
Next i
End Sub
EDIT: Need to separate each block of text separated by a space (outlined in blue) to this
Create a 2D array with one column and load that:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
ReDim arr(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim i As Long
i = 1
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
arr(i, 1) = wPara.Range
i = i + 1
End If
Next wPara
[a1].Resize(UBound(arr) + 1) = arr
End Sub
Copy Word Paragraphs to Excel Cells Using an Array
The number of rows of the array is wDoc.Paragraphs.Count which may differ from r (the 'actual count') hence you have to use r with Resize, and not wDoc.Paragraphs.Count or UBound(Data, 1).
Don't forget to Close the Document and Quit the App.
The first solution is early-bound and needs the library reference. When using it, just use
Set wApp = New Word.Application.
The second solution is late-bound and doesn't need the library reference. Also, it has been 'stripped off' the document and application variables (not necessary, you can declare them As Object).
Option Explicit
' e.g. Tools>References>Microsoft Word 16.0 Object Library
Sub ParaCopy()
Const FilePath As String = "J:\Data Dictionary.docx"
Dim wApp As Word.Application: Set wApp = Set wApp = New Word.Application
Dim wDoc As Word.Document: Set wDoc = wApp.Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim wPara As Word.Paragraph
Dim r As Long
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
wDoc.Close False
wApp.Quit
[a1].Resize(r) = Data
End Sub
Sub ParaCopyNoReference()
Const FilePath As String = "J:\Data Dictionary.docx"
With CreateObject("Word.Application")
With .Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To .Paragraphs.Count, 1 To 1)
Dim wPara As Object
Dim r As Long
For Each wPara In .Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
.Close False
End With
.Quit
End With
[a1].Resize(r) = Data
End Sub
I have two slicers on Sheet1 (Status1&Server). I want to store the selected elements, reset the slicers, and select them again after running a sort macro. Here's what I have:
Option Explicit
Sub GetSlicerNCSTatusSel()
Dim MyArrStatus() As Variant
Dim MyArrServer() As Variant
MyArrStatus = ArrayListOfSelectedAndVisibleSlicerItems("Slicer_Status1")
MyArrServer = ArrayListOfSelectedAndVisibleSlicerItems("Slicer_Server")
Dim slcr As SlicerCache
Dim slc As Slicer
Dim element As Variant
'Application.ScreenUpdating = False
For Each slcr In ActiveWorkbook.SlicerCaches
For Each slc In slcr.Slicers
If slc.Shape.Parent Is ActiveSheet Then
slcr.ClearManualFilter
Exit For
End If
Next slc
Next slcr
srtnc
For Each element In MyArrStatus
ActiveWorkbook.SlicerCaches("Slicer_Status1").SlicerItems(element).Selected = True
Next element
Application.ScreenUpdating = True
End Sub
Public Function ArrayListOfSelectedAndVisibleSlicerItems(MySlicerName As String) As Variant
Dim ShortList() As Variant
Dim i As Integer: i = 0 'for iterate
Dim sC As SlicerCache
Dim sI As SlicerItem 'for iterate
Set sC = ThisWorkbook.Application.ActiveWorkbook.SlicerCaches(MySlicerName)
For Each sI In sC.SlicerItems
If sI.Selected = True And sI.HasData = True Then 'Here is the condition!!!
'Debug.Print sI.Name
ReDim Preserve ShortList(i)
ShortList(i) = sI.Value
i = i + 1
End If
Next sI
ArrayListOfSelectedAndVisibleSlicerItems = ShortList
End Function
I think the problem is somewhere in the following portion. I just have no idea what I'm doing wrong as I am a bit of a VBA newb.
For Each element In MyArrStatus
ActiveWorkbook.SlicerCaches("Slicer_Status1").SlicerItems(element).Selected = True
Next element
I need a public function to get array and counts values in specific column.
I wrote the following and recives subscription out of range message.
Public Function CountUarrcol(inarr() As Variant, colidx As Integer) As Long
Dim col As New Collection
Dim i As Integer
Dim element As Variant
For i = 0 To UBound(inarr, colidx)
For Each element In inarr(i + 1, colidx)
col.Add Item:=CStr(element.value), Key:=CStr(element.value)
Next
Next i
CountUarrcol = col.Count End Function
Assuming you want to do a count of distinct values within a specified column of an array, here is an example with a 5*3 array read in from a worksheet range, counting the distinct values in column 2. I am using a function by Mark Nold to check if the value to be added already exists in the collection.
Option Explicit
Public Sub test()
Dim testArr()
Dim myCount As Long
testArr = ActiveSheet.Range("A1:C5").Value
myCount = CountUarrcol(testArr, 2)
MsgBox myCount
End Sub
Public Function CountUarrcol(inarr() As Variant, colidx As Long) As Long
Dim col As New Collection
Dim i As Long
For i = 1 To UBound(inarr)
If Not InCollection(col, CStr(inarr(i, colidx))) Then
col.Add Item:=CStr(inarr(i, colidx)), key:=CStr(inarr(i, colidx))
End If
Next i
CountUarrcol = col.Count
End Function
'Mark Nold https://stackoverflow.com/questions/137845/determining-whether-an-object-is-a-member-of-a-collection-in-vba
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
I Used two sub routine as follow:
Public Function CountUvalinarrcol(ByRef inarr As Variant, ByVal colidx As Integer) As Long
Dim col As New Collection
Dim i As Integer
Dim element As Variant
For i = 1 To UBound(inarr)
element = inarr(i, colidx)
If colContains(col, element) = False Then
col.Add item:=CStr(element)
End If
Next i
CountUvalinarrcol = col.Count
End Function
The other one is:
Public Function colContains(colin As Collection, itemin As Variant) As Boolean
Dim item As Variant
colContains = False
For Each item In colin
If item = itemin Then
colContains = True
Exit Function
End If
Next
End Function
Calling above functions:
sub test()
dim x as long
x= CountUvalinarrcol(lsarr, 0)
end sub
I'm trying to create a function (that when you pass it an array (Maybe a range is better?) that it outputs all the unique values in the same row on different cells.
I've gotten as far as knowing how to identify the elements (which I don't think I've done right :( ) but I'm not sure how I'd output all the unique values. I only get the first one.
My code is as follows:
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
'If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
AddItem:
'If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
Something like:
Function UniqueItems(ArrayIn) As Variant
Dim vData As Variant
Dim vNewdata() As Variant
Dim colUniques As Collection
Dim lCt As Long
If TypeName(ArrayIn) = "Range" Then
vData = ArrayIn.Value
Else
vData = ArrayIn
End If
Set colUniques = New Collection
'assuming a one-column range
On Error Resume Next 'ignore duplicates
For lCt = 1 To UBound(vData, 1)
colUniques.Add vData(lCt, 1), CStr(vData(lCt, 1))
Next
ReDim vNewdata(1 To 1, 1 To colUniques.Count)
For lCt = 1 To colUniques.Count
vNewdata(1, lCt) = colUniques(lCt)
Next
UniqueItems = vNewdata
End Function
you might use Scripting.dictionary to get unique value fast as for exemple
Sub TestArray()
Dim arrStart() As Variant
Dim oDic As Scripting.Dictionary
arr = Array(1, 1, 1, 2, 3, 4, 4, 5)
Set oDic = uniquevalue(arr)
'Note : put data into array
Dim arrResult() As Variant
arrResult = oDic.Keys
'Note : put data into string
Dim stringResult As String
stringResult = Join(oDic.Keys, ";")
End Sub
Function uniquevalue(ByVal myArray) As Scripting.Dictionary
'Note : Add REF DLL Microsoft Srcipting Runtime before !!
'Note : Option base =0 (standard vbe param)
'Note : Array is mono dimension of any data type
Dim oDic As Scripting.Dictionary
Set oDic = New Scripting.Dictionary
For i = LBound(myArray) To UBound(myArray)
If Not oDic.Exists(myArray(i)) Then oDic.Add myArray(i), oDic.Count
Next i
Set uniquevalue = oDic
End Function
Here is the VBA function that populates an array with a unique set of months, generated from a start month and an end month:
Function get_months(matrix_height As Integer) As Variant
Worksheets("Analysis").Activate
Dim date_range As String
Dim column As String
Dim uniqueMonths As Collection
Set uniqueMonths = New Collection
Dim dateRange As range
Dim months_array() As String 'array for months
column = Chr(64 + 1) 'A
date_range = column & "2:" & column & matrix_height
Set dateRange = range(date_range)
On Error Resume Next
Dim currentRange As range
For Each currentRange In dateRange.Cells
If currentRange.Value <> "" Then
Dim tempDate As Date: tempDate = CDate(currentRange.Text) 'Convert the text to a Date
Dim parsedDateString As String: parsedDateString = Format(tempDate, "MMM-yyyy")
uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
End If
Next currentRange
On Error GoTo 0 'Enable default error trapping
'Loop through the collection and view the unique months and years
Dim uniqueMonth As Variant
Dim counter As Integer
counter = 0
For Each uniqueMonth In uniqueMonths
ReDim Preserve months_array(counter)
months_array(counter) = uniqueMonth
Debug.Print uniqueMonth
counter = counter + 1
Next uniqueMonth
get_months = months_array
End Function
How can I manipulate this function to return the cell rows of each of the values that are being added to my months array.
What would be the best way to store these two values i.e. The Date (Oct-2011) & the Row Number (i.e. 456)
Tow arrays? Then return an array with these two arrays within it?
Can anyone give provide a solution to this problem?
NOT FULLY TESTED
Just a quick example I threw together think this is what you are looking for, let me know of any changes you may need and I'd be glad to help.
This is sloppy and unfinished but working, as far as I know, Test in a copy of your actual data and not on your actual data. When I get some more time I can try to clean up more.
Function get_months(matrix_height As Integer) As Variant
Dim uniqueMonth As Variant
Dim counter As Integer
Dim date_range() As Variant
Dim column As String
Dim uniqueMonths As Collection
Dim rows As Collection
Set uniqueMonths = New Collection
Set rows = New Collection
Dim dateRange As Range
Dim months_array() As String 'array for months
date_range = Worksheets("Analysis").Range("A2:A" & matrix_height + 1).Value
On Error Resume Next
For i = 1 To matrix_height
If date_range(i, 1) <> "" Then
Dim parsedDateString As String: parsedDateString = Format(date_range(i, 1), "MMM-yyyy")
uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
If Err.Number = 0 Then rows.Add Item:=i + 1
Err.Clear
End If
Next i
On Error GoTo 0 'Enable default error trapping
'Loop through the collection and view the unique months and years
ReDim months_array(uniqueMonths.Count, 2)
For y = 1 To uniqueMonths.Count
months_array(y, 1) = uniqueMonths(y)
months_array(y, 2) = rows(y)
Next y
get_months = months_array
End Function
And can be called like:
Sub CallFunction()
Dim y As Variant
y = get_months(WorksheetFunction.Count([A:A]) - 1)
End Sub
Function:
Function get_months() As Variant
Dim UnqMonths As Collection
Dim ws As Worksheet
Dim rngCell As Range
Dim arrOutput() As Variant
Dim varRow As Variant
Dim strRows As String
Dim strDate As String
Dim lUnqCount As Long
Dim i As Long
Set UnqMonths = New Collection
Set ws = Sheets("Analysis")
On Error Resume Next
For Each rngCell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)).Cells
If IsDate(rngCell.Text) Then
strDate = Format(CDate(rngCell.Text), "mmm-yyyy")
UnqMonths.Add strDate, strDate
If UnqMonths.Count > lUnqCount Then
lUnqCount = UnqMonths.Count
strRows = strRows & " " & rngCell.Row
End If
End If
Next rngCell
On Error GoTo 0
If lUnqCount > 0 Then
ReDim arrOutput(1 To lUnqCount, 1 To 2)
For i = 1 To lUnqCount
arrOutput(i, 1) = UnqMonths(i)
arrOutput(i, 2) = Split(strRows, " ")(i)
Next i
End If
get_months = arrOutput
End Function
Call and output:
Sub tgr()
Dim my_months As Variant
my_months = get_months
With Sheets.Add(After:=Sheets(Sheets.Count))
.Range("A2").Resize(UBound(my_months, 1), UBound(my_months, 2)).Value = my_months
With .Range("A1:B1")
.Value = Array("Unique Month", "Analysis Row #")
.Font.Bold = True
.EntireColumn.AutoFit
End With
End With
End Sub