I'm having a problem when scraping a certain page.
Usually this method works fine but in this case its not working as intended
I'm trying to extract single value an put each one in different cell but the application outputs whole row as single string.
Values have been obscured
Page snippet
Set Data = html.getElementById("function-4300006681") 'Sweeper [4300006681]
Set tr = html.getElementsByTagName("tr")
Set td = html.getElementsByTagName("td")
Set Table = html.getElementsByTagName("tbody")
For Each tr In Table
row = row + 1
For Each td In tr.Children
col = col + 1
PPR_IBPS.Cells(row, col).Value = td.innerText
Next td
col = 0
Next tr
any ideas what I'm missing? its a problem wit the <a tag or the empty values? any guidance appreciated
If found a solution myself after hitting the wall with all direction so i post it if its useful for someone :)
Set Data = html.getElementById(func)
Set tr = html.getElementsByTagName("tr")
Set td = html.getElementsByTagName("td")
Set Table = html.getElementsByTagName("tbody")
Set tditem = html.getElementsByTagName("td").Item()
For Each tr In Data.Children
For Each td In tr.Children
row = row + 1
For Each tditem In td.Children
col = col + 1
'Debug.Print tditem.innerText
PPR_IBPS.Cells(row, col).Value = tditem.innerText
Next tditem
col = 0
Next td
Next tr
Basically just looped another time for each item in td with another variable using .item()
Related
I'm updating a VBA script and trying to match a 4-digit code with a table and printing the two corresponding columns into my original sheet, plus handling codes missing from the reference table.
jobcodes = sample codes to match.
codematch = reference table, 1st column is reference codes, I want the corresponding values in columns 2 and 3 in K and L of "jobcodes".
At the minute I'm getting blank values in the first two rows, then #N/A errors in the rest of the sample table.
finrow3 = jobs.Cells(Rows.Count, 1).End(xlUp).Row
jobcodes = jobs.Range(("J2"), ("L" & finrow3)).Value
codematch = stat.Range("I2:K143").Value
For i = 1 To finrow3 - 1
For j = 1 To UBound(codematch, 1)
If StrComp(jobcodes(i, 1), codematch(j, 1)) = 0 Then
resulta(z, 1) = codematch(j, 2)
resulta(z, 2) = codematch(j, 3)
Else
resulta(z, 1) = ""
resulta(z, 2) = ""
End If
Next j
Next i
jobs.Range(("K2"), ("L" & finrow3)).Value = Application.Transpose(resulta)
I have a template based on the repetition of two pages with two different tables. I am working on a macro to adjust the row heights of these tables throughout the document so that the row heights are the same. Sometimes the tables stay on the page, sometimes it does overflows continuously onto a new page.
I have been trying a few different ways and the below is the closest I have come to getting it to work. Below gets the actual row height by looking at the position against the document. The issue I am having is that the tables are crossing pages and so keeps showing an error when it gets to a row on the next page. The error is 'The measurement must be between 0 pt and 1584 pt.'
This is the code I am currently using:
A = 1
B = 2
While B <= ActiveDocument.Tables.Count
Set T1 = ActiveDocument.Tables(A)
Set T2 = ActiveDocument.Tables(B)
Set R1 = T1.Rows
Set R2 = T2.Rows
Set C1 = T1.Columns
Set C2 = T2.Columns
For i = 1 To R1.Count()
If i = R1.Count() Then
Else
H1 = T1.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T1.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
H2 = T2.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T2.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
If H1 > 0 Or H1 < 1584 Or H2 > 0 Or H2 < 1584 Then
If H1 > H2 Then
R2(i).Height = H1
Else
R1(i).Height = H2
End If
End If
End If
Next
A = A + 1
B = B + 2
Wend
I have also tried setting the height using the below, which doesn't work in this case as it only gets the default height of the row and not the actual height.
H1 = R1(i).Height
H2 = R2(i).Height
Thank you for any help in advance.
Thank you to everyone who helped. I ended up resolving this by using the following code and making the page of the document extremely long. Not ideal, but worked.
Sub rowHeight()
A = 2
B = 4
While B <= ActiveDocument.Tables.Count
Set T1 = ActiveDocument.Tables(A)
Set T2 = ActiveDocument.Tables(B)
Set r1 = T1.Rows
Set r2 = T2.Rows
Set C1 = T1.Columns
Set C2 = T2.Columns
On Error Resume Next
For i = 1 To r1.Count()
If i = r1.Count() Then
Else
H1 = T1.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T1.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
H2 = T2.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T2.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
'H1 = R1(i).Height
'H2 = R2(i).Height
If H1 > 0 & H1 < 1584 & H2 > 0 & H2 < 1584 Then
If H1 > H2 Then
r2(i).Height = H1
Else
r1(i).Height = H2
End If
End If
End If
Next
A = A + 4
B = B + 4
Wend
End Sub
I have a sheet with 2 tables. I want to find and return the cell of column 1 which has the minimum proteges.
For example, my code would return either Phil,Levy or Sean, Montain in the first run. (then my spreadsheet will add +1 to one of the two - this is already set in excel). etc....
Coach List Protégées
Phil, Levy 7
Sean, Monteine 7
Victor, Chatelais 8
I have write a code but unfortunately ot does it randomly. Any thoughts ?
Code:
Dim Coach As String
Dim ws As Worksheet, t As ListObject, r As Long
For Each t In MyWorksheet.ListObjects
Select Case t.Name
Case "Table1", "Table3", "Table4", "Table6", "Table8", "Table10", "Table12", "Table14", "Table16"
'do nothing
Case Else
'Coach = Application.WorksheetFunction.Min(t.ListColumns(2).Range)--> could use that ?
For r = 1 To t.DataBodyRange.Rows.Count
For r = t.DataBodyRange.Rows.Count To 1 Step -1
If t.DataBodyRange(r, 2) <= t.DataBodyRange(r + 1, 2) Then
Coach = t.DataBodyRange(r , 1)
End If
Next r
End Select
Next t
I think your method needs a variable for the lowest number found as each row is compared.
p = 9999
For r = 1 To t.DataBodyRange.Rows.Count
If t.DataBodyRange(r, 2) <= p Then
p = t.DataBodyRange(r, 2)
Coach = t.DataBodyRange(r, 1)
End If
Next r
Two days of continual failure. I am using a barcode system which has a barcode scanner which scans a barcode of alpha-numeric text and places it into an ActiveX textbox. It enters the text one letter at a time, and upon the completion of the entire barcode, it matches up to a Case selection, which then deletes the text in the box to get ready for the next scan.
The issue I happen to be facing is inside of the textbox. For whatever reason, the text goes into the textbox and occasionally ~ (1 time in one hour or 0 times in 8 hours) it will not complete the case. The exact text inside of the textbox which matches one of the cases is not counted and stays inside the box. At this point, any future scans are appended to the end of the text inside of the box.
Below is a sample of the variables, a case, and one of the events occuring based on case selection.
Variables
Private Sub TextBox1_Change()
Dim ws As Worksheet, v, n, t, b, c, e, f, h, j, k, i1, i2, i3, i4
Set ws = Worksheets("Sheet1")
v = TextBox1.Value
n = 0
t = 0
b = 0
c = 0
e = 0
f = 0
h = 0
j = 0
k = 0
i1 = 0
i2 = 0
i3 = 0
i4 = 0
Case
Select Case v
Case "2 in x 16 ft R -1": n = 9
t = 1
b = 10
c = 1
e = 11
f = 6
g = "2 in x 16 ft"
h = 40
j = 0.296
k = 1
Stuff that is done based on case type
'n = Sets the column reference for waste - not used?
't = Sets the cutting station column to be used (1,2,3) for the sq yards, row, and column of last scanned item for each station
'b = Sets the row reference for adding cut rolls waste + regular row reference for cut rolls
'c = Sets the column reference for adding cut rolls waste + regular column refernce for cut rolls
'e = Sets the column reference for taking 1 master roll out
'f = Sets the row reference for taking 1 master roll out
'g = name of the item being used for the time stamp
'h = Number of rolls coming out of the master roll
'j = The amount of Sq yards in the cut roll (to be used for waste)
'k = Case Selection
'i1 = Count for Cutting Station 1 timestamp, row reference
'i2 = Count for Cutting Station 2 timestamp, row reference
'i3 = Count for Cutting Station 3 timestamp, row reference
'i4 = Count for Cutting Station 1 timestamp, row reference - not used in this worksheet
If k = 1 And t = 1 Then
'Cutter 1 items
ws.Cells(1, t) = b
ws.Cells(2, t) = c
ws.Cells(3, t) = j
ws.Cells(4, t) = b
ws.Cells(5, t) = c
ws.Cells(6, t) = f
ws.Cells(7, t) = h
ws.Cells(b, c) = ws.Cells(b, c) + h
' adding different number based on case
ws.Cells(f, e) = ws.Cells(f, e) - 1
' always subtracts 1 from certain range based on case
i1 = ws.Cells(1, 30)
Cells(i1, 19).Value = Format(Now, "mm/dd/yyyy AM/PM h:mm:ss")
Cells(i1, 20).Value = g
TextBox1.Activate
TextBox1.Value = ""
Remember the text enters in one character at a time until the entire barcodes information is passed into the ActiveX textbox.
I can set a max length, but upon the max length it stays in the textbox. If I set the textbox to "", the next character in the barcode starts again and the append issue continues.
Is there a way to not have the case selection start upon the entry of each single character? Is there a way to have the textbox delete the extra information. If you set it to delete something which does not match a case, then it will delete anything entered since it puts one character in at a time.
Best regards,
Ford
I am creating a chart from data inside an Excel sheet. Everything works. But now I want to remove values that are below a limit and display them as "Others". Removing them works but I don't know how to add an additonal "others" value.
This is part of the code:
Co.chart.SetSourceData Source:=DataSource
Co.chart.ChartTitle.Text = "Best selling games"
Co.chart.SeriesCollection(1).ApplyDataLabels ShowPercentage:=True, ShowValue:=False
For Each d In Co.chart.SeriesCollection(1).DataLabels
v = CLng(Split(d.Caption, "%")(0))
If v < 10 Then
Rest = Rest + v
d.Delete
End If
Next
If Rest > 0 Then
Co.chart.SeriesCollection(1).DataLabels.AddData("Others",Rest); ' HERE
End If
In the second last line is some pseudocode about what I want to achieve.
I found a "dirty" solution for this. Instead of deleting the first item I RENAME it to "Others" instead of deleting it and adding the "Others" afterwards:
For Each d In Co.chart.SeriesCollection(1).DataLabels
Counter = Counter + 1
v = CLng(Split(d.Caption, "%")(0))
If v <= 10 Then
If RestPos < 0 Then
RestPos = Counter
Else
d.Delete
End If
Rest = Rest + v
End If
Next
If Rest > 0 Then
Co.chart.SeriesCollection(1).DataLabels(RestPos).Caption = Rest & " %"
End If