I am trying to fetch data from a webpage. My VBA code is as below
m = 0
For Each htmlele1 In doc.getElementsByClassName("resultsbranch")
m = m + 1
companyname = htmlele1.getElementsByTagName("h2")
Address = htmlele1.getElementsByTagName("span")
If Address.getAttribute("itemprop") = "myaddress" Then
Range("D" & i).Value = companyname.innerText + "," + Address.innerText
End If
Teliphone = htmlele1.getElementsByClassName("teldata")
If Teliphone.getAttribute("itemprop") = "tel" Then
Range("E" & i).Value = Teliphone.innerText
End If
'i = i + 1
'Debug.Print i
Next
On the first iteration, values are get inserted to columns D,E
on second iteration I want to insert data To F,H .
On 3 rd iteration I,J
On 4th iteration K,L
So on up to nth iteration
How can i do this ?
Instead of:
Range("D" & i).Value
Range("E" & i).Value
Use:
Cells(i, (m*2 + 3)).Value
Cells(i, (m*2 + 4)).Value
Or use another counter... As you like... Hope that helps.
Related
I just started learning VBA but I can't really figure this out thing out.
I have a column with both positive and negative integers and what I want to do is to take the values that are positive and put them in a new column, and do the same for the negative values.
I tried making an if-statement but I only know how to shift their spots horizontally, so if I have a positive value in row 1,5,7,22 and 24 they'll appear in these rows in the next column instead of being in row 1,2,3,4 and 5.
I did that like this:
For i = 0 To NoofOb
If Range("D3").Offset(i + 1) > 0 Then
Range("G3").Offset(i) = Range("D3").Offset(i + 1)
ElseIf Range("D3").Offset(i + 1) < 0 Then
Range("J3").Offset(i) = Range("D3").Offset(i + 1)
End If
Next i
Could someone give me a hint or anything? I've been looking at this for hours and can't find an answer. Thanks in advance!
Try this:
j = 1
k = 1
For i = 3 To NoofOb
If Range("D" & i).Value > 0 Then
Range("G" & j).Value = Range("D" & i).Value
j = j + 1
ElseIf Range("D" & i).Value < 0 Then
Range("J" & k).Value = Range("D" & i).Value
k = k + 1
End If
Next i
note: I did not test this code and you may need to adjust the starting points of each column (i, j and k) to suit your needs
Another option, assuming columns G and J are empty before starting the macro
For i = 3 To NoofOb
With Range("D" & i) ‘ reference column D current i row
Select Case .Value2 ‘check referenced range value and sct accordingly
Case Is > 0 ‘ if it’s positive
Range("G" & Worksheetfunction.Count(Range("G:G")) + 1.Value2 = .Value2 ‘ fill column G next empty row
Case Is < 0 ‘ if it’s negative
Range("J" & Worksheetfunction.Count(Range("J:J")) + 1.Value2 = .Value2 ‘ fill column J next empty row
End Select
End With
Next
I'm trying to copy values from one small sheet "MD with ID" to A Larger sheet "D with ID" if 2 fields are identical (consider those two as keys that identify each record).
Here is my first try:
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Here is my second try:
Sub CopyIDCells2()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until j = 20886
d = 2
Do Until d = 1742
If e.Cells(j, 3).Value = i.Cells(d, 4).Value Then
If e.Cells(j, 13).Value = i.Cells(d, 10).Value Then
e.Cells(j, 1).Value = i.Cells(d, 2).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Nothing changes in the excel sheet when this code runs, although it takes few minutes to run -_-".
.. sample was removed
So looking at your first CopyIdCells method, there is only one fix I would make to this - make variable d=2. This has headers at the top of your sample data and you need to start on row 2 just like the other sheet.
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Other than that your formulas look good, you just do not have any data that meets your requirements. Add this column to the bottom of "MD with ID" and you will see your code match.
mouse 10 08 11267 A/J M 823 1/11/2008 1 SC-807 LONG 10/10/2005
Since you are matching on "Case Number" AND "Other ID" there are no items in both sheets that meet this criteria. When you add the row above to "MD with ID", you will see the appropriate ID added to your second sheet on several rows.
In my spreadsheet, I have a list of data in a column that has item numbers. Given a value (either "'1 Quad" or any value A-D) in an adjacent cell, there should be no rows with repeating item numbers or 8 rows with repeating item numbers respectively in the same column. If there are more or less than the required amount of item numbers (too many repeating numbers or missed numbers), then I would like the entire variable range of identical item numbers to highlight (which I am simply doing with Fill).
For i = 3 To (mainRow - 1)
k = i
j = i
If Range("G3") = "'1 Quad" Then
If Range("E" & i).Value > (Range("E" & (i + 1)).Value - 1) Then
Range("E" & i, "E" & (i + 1)).Interior.Color = RGB(255, 0, 0)
i = i + 1
End If
If Range("E" & i).Value < (Range("E" & (i + 1)).Value - 1) Then
Range("E" & i, "E" & (i + 1)).Interior.Color = RGB(0, 255, 0)
i = i + 1
End If
ElseIf Range("G3").Value = "A" Or "B" Or "C" Or "D" Then
Do
If Range("E" & j).Value = Range("E" & (j + 1)).Value Then
j = j + 1
End If
If Range("E" & j).Value <> Range("E" & (j + 1)).Value Then
If j < 8 Then
For k = i To j
Range("E" & i).Interior.Color = RGB(255, 0, 0)
Next k
End If
If j > 8 Then
For k = i To j
Range("E" & i).Interior.Color = RGB(0, 255, 0)
Next k
End If
Exit Do
End If
While j < (mainRow - 1)
i = k
End If
Next i
With This code, I am getting the error "End If without Block If" which does not appear to be the case at all. If I remove the last "End IF", I receive the "Next without For" error. Thanks ahead of time for your help.
**I edited the code to include the end ifs and still receiving the same error.
You're missing 3 End Ifs, and your Do-While syntax is off. Try this instead:
Do While j < (mainRow - 1)
If Range("E" & j).Value <> Range("E" & (j + 1)).Value Then
If j < 8 Then
For k = i To j
Range("E" & i).Interior.Color = RGB(255, 0, 0)
Next k
Exit Do
End If
If j > 8 Then
For k = i To j
Range("E" & i).Interior.Color = RGB(0, 255, 0)
Next k
Exit Do
End If
End If
Loop
I have four columns, loop over two of the columns using nested do while loops, and then two if statements to act as constraints. If the two if statements are passed, revalue (paste is an option too), two new cells to the values of the cells that were checked using the index on the first loop, and another two new cells to the values of the cells that were checked using the index on the nested loop.
code:
Dim i
Dim j
i = 1
j = 1
Do Until IsEmpty(Range("BE" & i))
Do Until IsEmpty(Range("BH" & j))
If Cells(i, "BE").Value = Cells(j, "BH").Value Then
If (Cells(j, "BG").Value - Cells(i, "BF")) < TimeValue("1:00:00") Then
'This is not correctly filtering, dates/time are in
' mm/dd/yy hh:mm format
Range("BJ" & i).Value = Range("BE" & i).Value
Range("Bk" & i).Value = Range("BF" & i).Value
Range("BL" & i).Value = Range("BG" & j).Value
Range("BM" & i).Value = Range("BH" & j).Value
End If
End If
j = j + 1
Loop
i = i + 1
j = 1
Loop
End Sub
What it does:
It does almost everything correctly. The issue is that it does NOT correctly check if the difference in time between cells BG(j) and BF(i) < 60 minutes. Whether using:
If (Cells(j, "BG").Value - Cells(i, "BF")) * 1440 < 60 Then
or
IF (Cells(j, "BG").Value - Cells(i, "BF")) < TimeValue("1:00:00") Then
values that are 5 hours in difference are being seen as true and passing through the if statement.
Try adding j = 1 just after i = i + 1
I am looking for the best way to clean up the cell contents of one particular cell in my spreadsheet. As it exists now, Column D lists a City, State, and High School in the same cell (Screenshot #1). I need to split these values out into 3 unique columns/cells as shown in Screenshot #2. How would I accomplish this?
** Note - The example below is just a sample size. I have thousands of cells to perform this on.
Existing cell format:
New Format (Hopefully):
Use Text-to-Columns "delimited" to split on the comma, then use it again "fixed width" to split the state from the school name (assuming the state is always 2 characters). Clean up spaces with TRIM if required.
Hi something like this should look through all your cells in row D and return the values you are looking for in the next 3 columns; might need a little adjusting
For each cell in Range("D2:D & Range("D2".End(xlDown).Row))
cell.offset(columnOffset:=1) = left(cell,instr(String1:=cell, String2:= ","))
cell.offset(columnOffset:=2) = Mid(cell,instr(String1:=cell, String2:= ",")+1,2)
cell.offset(columnOffset:=3) = right(cell,len(cell)-instr(String1:=cell, String2:= ",")+3)
Next
I tried Jake Duddy's code it contains quite some errors, I do not know if it works. At the same time you can try below code.
Dim LastRow As Long
Dim State_L As String
Dim City_L As String
Dim HS_L As String
LastRow = Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
City_L = Left(Range("D" & i), InStr(1, Range("D" & i), ",") - 1) ' Getting up to comma
State_L = Mid(Range("D" & i), InStr(1, Range("D" & i), ",") + 1, 2) 'Getting after comma for 2 characters
HS_L = Mid(Range("D" & i), InStr(1, Range("D" & i), ",") + 3, Len(Range("D" & i)) - InStr(1, Range("D" & i), ",")) 'Getting after comma+2 characters upto the end
Range("E" & i).Value = City_L
Range("F" & i).Value = State_L
Range("G" & i).Value = HS_L
Next
Select the cells you wish to process and run this small macro:
Sub ParseData()
Dim r As Range, L As Long, L1 As Long, L2 As Long
For Each r In Selection
t = r.Text
L = Len(t)
L1 = InStr(1, t, ",")
For i = 1 To L
If r.Characters(i, 1).Font.Italic = True Then
L2 = i
Exit For
End If
Next i
r.Offset(0, 1).Value = Mid(t, 1, L1 - 1)
r.Offset(0, 2).Value = Mid(t, L1 + 1, L2 - L1 - 1)
r.Offset(0, 3) = Mid(t, L2)
r.Offset(0, 3).Font.Italic = True
Next r
End Sub
For example: