I've written a script in vba using which I can parse "Company Name", "Phone", "Fax" and "Email" from a specific site but in case of scraping "Address", "Web" and "Name" I got stuck. I've written the script using responsetext and split method in vba. Hope there is someone to show me a workaround.
Here is what i tried with:
str = Split(http.responseText, " class=""contact-details block dark"">")
y = UBound(str)
For i = 1 To y
Cells(x, 1) = Split(Split(str(i), "Company Name:")(1), "<")(0)
Cells(x, 2) = Split(Split(str(i), "Phone:")(1), "<")(0)
Cells(x, 3) = Split(Split(str(i), "Fax:")(1), "<")(0)
Cells(x, 4) = Split(Split(str(i), "mailto:")(1), ">")(0)
x = x + 1
Next i
Here goes the html element stuff:
<div class="contact-details block dark">
<h3>Contact Details</h3><p>Company Name: PPEHeads Australia<br>Phone: +61 2 9824 5520<br>Fax: +61 2 9824 5526<br>Web: <a target="_blank" href="http://www.ppeheads.com.au">http://www.ppeheads.com.au</a></p><h4>Address</h4><p>Unit 2 / 4 Reaghs Farm Road<br>MINTO<br>NSW<br>2566</p><h4>Contact</h4><p>Name: Alan Hadfield<br>Phone: +61 2 9824 5520<br>Fax: +61 2 9824 5526<br>Email: alan#ppeheads.com.au</p>
</div>
Please provide the rest of your code next time, because the problem might not be where you think it is. Luckily I found your previous post here
If you take a closer look there are 3 p tags within your html element:
1st one is for Contact Company Details which you can get by
Set ele = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(0)
2nd one is for Address Details which you can get by
Set ele2 = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(1)
3rd one is for Contact Person Details which you can get by
Set ele3 = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(2)
Notice (0), (1), (2) changes at the end of code which gives you the appearance order of p tag.
I amended your previous code and commented the changes so you can see the difference:
Sub RestData()
Dim http As New MSXML2.XMLHTTP60
Dim html As New HTMLDocument
Dim ele, ele2, ele3 As Object, post As Object 'declare
Dim TypeDetails() As String
Dim TypeDetails3() As String 'declare
Dim TypeDetail() As String
Dim i As Long, r As Long
With CreateObject("MSXML2.serverXMLHTTP")
.Open "GET", "http://www.austrade.gov.au/SupplierDetails.aspx?ORGID=ORG0120000508&folderid=1736", False
.send
html.body.innerHTML = .responseText
End With
'get all the p elements
Set ele = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(0)
Set ele2 = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(1)
Set ele3 = html.getElementsByClassName("contact-details block dark")(0).getElementsByTagName("p")(2)
r = 2
'split from line feed
TypeDetails() = Split(ele.innerText, Chr(10))
TypeDetails3() = Split(ele3.innerText, Chr(10))
'This part goes for Contact Company Details, notice the operator is ": ",not ":"
For i = 0 To UBound(TypeDetails())
TypeDetail() = Split(TypeDetails(i), ": ")
Cells(r, 1) = VBA.Trim(TypeDetail(0))
Cells(r, 2) = VBA.Trim(TypeDetail(1))
r = r + 1
Next i
'This part goes for Address Details, replaced new line with " " for it to be in the same line
Cells(r, 1) = "Address"
Cells(r, 2) = Replace(ele2.innerText, vbLf, " ")
r = r + 1
'This part goes for Contact Person Details
For i = 0 To UBound(TypeDetails3())
TypeDetail() = Split(TypeDetails3(i), ": ")
Cells(r, 1) = VBA.Trim(TypeDetail(0))
Cells(r, 2) = VBA.Trim(TypeDetail(1))
r = r + 1
Next i
Set html = Nothing: Set ele = Nothing: Set docs = Nothing
End Sub
I hope this helps
Related
Greeting to all Members and Experts, I am trying to automate
the formatting process in word. The formatting is done by applying styles. But before applying styles I need to trim extra spaces between characters of serial numbers, for example, 1. a. i. and insert tabs after dot(.) and then apply the style. I have attached a sample document. Plz have a look. I have tried to get the desired result by using the following code but it doesn't get the work done
I am new here so i dont know how to attach sample files so, here is the link for sample file. https://docs.google.com/document/d/1Z1dB6tvPKVrxHlw7qV8VNyiy49c5lRZN/edit?usp=sharing&ouid=101706223056224820285&rtpof=true&sd=true
Any help or suggestion would be of great help. Thanks in advance...
Sub formatts()
Dim a As Integer
Dim i As Integer, n As Long, para As Paragraph, rng As Range, doc As Document
Set doc = ActiveDocument
With doc
For i = 1 To .Range.Paragraphs.Count
For n = 1 To doc.Paragraphs(i).Range.Characters.Count
If .Paragraphs(i).Range.Characters(n).Text = " " Or .Paragraphs(i).Range.Characters(n).Text = Chr(9) Or .Paragraphs(i).Range.Characters(n).Text = Chr(160) Then
.Paragraphs(i).Range.Characters(n).Select
'This line checks whether the first character is whitespace character or not and delete it.
doc.Paragraphs(i).Range.Characters(n).Delete
ElseIf .Paragraphs(i).Range.Characters(n).Text = "." Then
.Paragraphs(i).Range.Characters(n).InsertAfter (vbTab)
n = n + 1
a = a + 1
ElseIf .Paragraphs(i).Range.Characters(n).Text Like "[a-z]." And .Paragraphs(i).Range.Characters(n).Next.Next.Text <> "i" Then
Exit For
End If
If a >= 3 Then Exit For
Next
For n = 1 To doc.Paragraphs(i).Range.Characters.Count
If .Paragraphs(i).Range.Characters(n).Text = "i" And .Paragraphs(i).Range.Characters(n).Next.Text = "." And .Paragraphs(i).Range.Characters(n).Next.Next.Text = " " Then
doc.Range.Paragraphs(i).Style = "shh"
Exit For:
ElseIf .Paragraphs(i).Range.Characters(n).Text = "a" Or .Paragraphs(i).Range.Characters(n).Text = "b" Or .Paragraphs(i).Range.Characters(n).Text = "c" And .Paragraphs(i).Range.Characters(n).Next.Text = "." And .Paragraphs(i).Range.Characters(n).Next.Next.Text = " " Then
doc.Range.Paragraphs(i).Style = "sh"
Exit For
End If
Next
Next
End With
End Sub
I've witten a script in vba to parse two categories from each container from a webpage. The scraper is able to parse them accordingly. The problem I'm facing at this moment is that I can't place these items across columns. If a column contains views, the next column should contains votes and so on. The way I'm expecting the result is more like:
column1 column2 column3 column4
9 views 0 vote 10 views -2
This is my script so far:
Sub CollectInfo()
Const URL As String = "https://stackoverflow.com/questions/tagged/web-scraping"
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim post As HTMLHtmlElement, R&, C&
With Http
.Open "GET", URL, False
.send
Html.body.innerHTML = .responseText
End With
R = 1
For Each post In Html.getElementsByClassName("question-summary")
C = C + 1: Cells(R, C) = post.getElementsByClassName("views")(0).innerText
Cells(R, C + 1) = post.getElementsByClassName("votes")(0).innerText
Next post
End Sub
The way I tried is definitely leading me to the wrong placing. How can I fix it to serve the purpose? Btw, I do not wish to go for the offset (I meant Range("A1").offset(,1)") looping ;rather, I wanna stick to the way I tried above. Thanks.
This will show views and votes by turns. I changed XMLHTTP60 to MSXML2.XMLHTTP60, because on my end it causes automation error.
Sub CollectInfo()
Const URL As String = "https://stackoverflow.com/questions/tagged/web-scraping"
Dim Http As New MSXML2.XMLHTTP60, Html As New HTMLDocument
Dim post As HTMLHtmlElement, R&, C&
With Http
.Open "GET", URL, False
.send
Html.body.innerHTML = .responseText
End With
R = 1
For Each post In Html.getElementsByClassName("question-summary")
C = C + 1
Cells(R, C) = post.getElementsByClassName("views")(0).innerText
C = C + 1
Cells(R, C) = post.getElementsByClassName("votes")(0).innerText
Next post
End Sub
I've got a really odd case… hopefully someone is able to help me out, I've search many forums looking for a solution, the closest I could find related to it (kinda) is here, though I've tried all the suggestions to no avail…
I'm trying to run a function to return a data list in a string delimitated by a semicolon from an oracle stored function. (This value function call seems to work fine).
I then loop through the string for each data value and print it to a blank table (0 rows) declared in my subroutine. which I use to load into an access data base. (just trust it make sense in the big picture…).
The issue, fundamentally is that no information is printed into the table. However when I step through the code it works fine.
After troubleshooting I THINK (see my test scenarios below code) the issue comes up after the listrows.add line... though not obviously.
I don't think this line is executed by the time the first value is trying to print to the table.
The most confusing part is I'm running through 2 nearly identical procedures (call function -> Return value -> print values to table) immediately before this portion of the code and they work without fail.
Code Excerpt:
'run function to get string ... this works
DoEvents ' not in original design
RelRtnStr = Prnt(Cat, "A Third Oracle Function Name")
DoEvents ' not in original design
RelChopVar = RelRtnStr
StrFldCnt = 0
Checking = True ''' CodeBreak Test 1
DoEvents ' not in original design
AppendRlLmTbl.ListRows.Add ''''''''This isn't appearing to work...
DoEvents ' not in original design
Debug.Print Now ' not in original design
Application.Wait (Now + TimeValue("0:00:3")) ' not in original design
Debug.Print Now ' not in original design
While StrFldCnt < 80 And (Len(RelChopVar) - Len(Replace(RelChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(RelChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(RelChopVar, InStr(RelChopVar, ";")), ";", "")
RelChopVar = Right(RelChopVar, Len(RelChopVar) - InStr(RelChopVar, ";"))
Else
'Last Value
FldVal = RelChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Table
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt))) ''' CodeBreak Test 2
AppendRlLmTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal '''CodeBreak 2 error thrown
Debug.Print StrFldCnt & FldNm & FldVal
Wend
AppendRlLmTbl.ListColumns("Catalogue").DataBodyRange.Value = Cat
So far I've tested a ton of options suggested online, not necessarily understanding each test... This is what I've gleaned.
If I step through the code, it works
If I set a breakpoint at "CodeBreak Test 1" and "F5" the rest, it works …
If I set a breakpoint at "CodeBreak Test 2" I get an "Object with variable not set" error thrown …
Things I've tried …
Wrapping anything and everything with DoEvents
setting a wait time after the listObjects.add row
Validated the code performs the While loop when running the "full procured" (as opposed to stepping through)
The worst part, I have no idea why the object won't declare properly when setting a break point after the add row line but sets properly when break point is set before and has no error thrown when running the full procedure (I have no on error declarations.)...
It of course must be related in my mind but I can't find any information online and unfortunately have no formal VBA background and 1 undergrad course as a programming background in general. Aka I'm out of my depth and super frustrated.
PS. first post, so please be nice :p
Full Code Below:
Option Explicit
'## Here's my attempt to clean up and standardize the flow
'## Declare my public variables
' WorkBook
Public WB As Workbook
' Sheets
Public Req2ByWS As Worksheet
Public ReqSpecsWS As Worksheet
Public ReqInstrcWS As Worksheet
Public ConfigReqWS As Worksheet
Public AppendReqWS As Worksheet
Public AppendRlLmWS As Worksheet
' Objects (tables)
Public ReqConfigTbl As ListObject
Public SpecConfigTbl As ListObject
Public CurrRegIDTbl As ListObject
Public AppendReqTbl As ListObject
Public AppendRlLmTbl As ListObject
'## ##
'## Get Data from Tom's Functions ##
Sub GetSpotBuyData()
'## Preliminary Config ##
'## Turn OFF Warnings & Screen Updates
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'## Set global Referances to be used in routine
' WorkBooks
Set WB = Workbooks("MyWb.xlsm")
' WorkSheets
Set Req2ByWS = WB.Sheets("MyWb Pg1")
Set ReqSpecsWS = WB.Sheets("MyWb Pg2")
Set ConfigReqWS = WB.Sheets("MyWb Pg3")
Set AppendReqWS = WB.Sheets("MyWb Pg4")
Set AppendRlLmWS = WB.Sheets("MyWb Pg5")
' Tables
Set ReqConfigTbl = ConfigReqWS.ListObjects("MyWS Tbl1")
Set SpecConfigTbl = ConfigReqWS.ListObjects("MyWS Tbl2")
Set CurrRegIDTbl = ConfigReqWS.ListObjects("MyWS Tbl3")
Set AppendReqTbl = AppendReqWS.ListObjects("MyWS Tbl4")
Set AppendRlLmTbl = AppendRlLmWS.ListObjects("MyWS Tbl5")
'## Declare Routine Specefic Variables
Dim Doit As Variant
Dim Checking As Boolean
Dim Cat As String
Dim CatRtnStr As String
Dim CatChopVar As String
Dim SpecRtnStr As String
Dim SpecChopVar As String
Dim RelRtnStr As String
Dim RelChopVar As String
Dim FldVal As String
Dim FldNm As String
Dim StrFldCnt As Integer
'## 1) General Set-Up ##
'## Unprotect tabs (loop through All Tabs Unprotect)
Doit = Protct(False, WB, "Mypassword")
'## Refresh Data
Doit = RunUpdateAl(WB)
'## 2) Find the Catalgue we are playing with ##
'## Grab Catalogue input from ISR
If [Catalogue].Value = "" Then
MsgBox ("Please Enter a Catalogue")
GoTo ExitSub
Else
Cat = [Catalogue].Value
End If
'## 3) Run Toms Function and print the results to the form & Append Table ##
'## 3a) Do it for Cat Info Function
'## Get Cat Info String From Function
CatRtnStr = Prnt(Cat, "An Oracle Functions Name")
CatChopVar = CatRtnStr
If CatChopVar = "No Info" Then
MsgBox ("No Info Found in Catalogue Data Search.")
GoTo SkipCatInfoPrint
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
AppendReqTbl.ListRows.Add
While Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(CatChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(CatChopVar, InStr(CatChopVar, ";")), ";", "")
CatChopVar = Right(CatChopVar, Len(CatChopVar) - InStr(CatChopVar, ";"))
Else
'Last Value
FldVal = CatChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(1, CStr(StrFldCnt)))
If FldNm <> "CustomerSpecification" And FldNm <> "ShiptoAddress" Then
'Take Value as is
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
ElseIf FldNm = "CustomerSpecification" Then
'Replace : with New Line
FldVal = Replace(FldVal, " : ", vbLf)
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
ElseIf FldNm = "ShiptoAddress" Then
'Replace - with New Line
FldVal = Replace(FldVal, " - ", vbLf)
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
End If
Wend
'## 3b) Do it for Spec Function
SkipCatInfoPrint:
'## Get Spec Info String From Function
SpecRtnStr = Prnt(Cat, "Another Oracle Functions Name")
SpecChopVar = SpecRtnStr
If SpecChopVar = "No Info" Then
MsgBox ("No Info Found in Data Search.")
GoTo SkipSpecInfoPrint
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
While StrFldCnt < 80 And (Len(SpecChopVar) - Len(Replace(SpecChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(SpecChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(SpecChopVar, InStr(SpecChopVar, ";")), ";", "")
SpecChopVar = Right(SpecChopVar, Len(SpecChopVar) - InStr(SpecChopVar, ";"))
Else
'Last Value
FldVal = SpecChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt)))
ReqSpecsWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
Wend
'## 3c) Do it for Rel Limits Function
SkipSpecInfoPrint:
'## Get Rel Limits String From Function
RelRtnStr = Prnt(Cat, "A Third Functions Name")
RelChopVar = RelRtnStr
If RelChopVar = "No Info" Then
MsgBox ("No Info Found in Data Search.")
GoTo ExitSub
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
AppendRlLmTbl.ListRows.Add
While StrFldCnt < 80 And (Len(RelChopVar) - Len(Replace(RelChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(RelChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(RelChopVar, InStr(RelChopVar, ";")), ";", "")
RelChopVar = Right(RelChopVar, Len(RelChopVar) - InStr(RelChopVar, ";"))
Else
'Last Value
FldVal = RelChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt)))
AppendRlLmTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
Wend
AppendRlLmTbl.ListColumns("SpecificFieldName").DataBodyRange.Value = Cat
'## 4) Re-Format and Clean Up Program ##
ExitSub:
'## Clean-Up Formatting
Req2ByWS.Range("F:F", "C:C").ColumnWidth = 30
Req2ByWS.UsedRange.Rows.AutoFit
Req2ByWS.UsedRange.Columns.AutoFit
Req2ByWS.Range("G:G").ColumnWidth = 15
Req2ByWS.Range("J:R").ColumnWidth = 12
Req2ByWS.Range("D:D").ColumnWidth = 12
'## Protect tabs (loop through All Tabs Protect)
'Doit = Protct(True, WB, "Mypassword", Req2ByWS.Name)
'Req2ByWS.Unprotect ("Mypassword")
'Application.Wait (Now + TimeValue("0:00:10"))
Req2ByWS.Select
'## Turn ON Warnings & Screen Updates
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I stupidly had an enable background refresh for that specific table. An early call to refresh all data triggered the refresh, code would execute and the refresh would finally complete shortly after the code finished executing... in break mode the refresh would complete prior too. Thanks PEH for helping me look into this.
I've written some code in vba to get all the links leading to the next page from a webpage. The highest number of next page links is 255. Running my script, I get all the links within 6906 links. That means the loop runs again and again and I'm overwriting stuffs. Filtering out duplicate links I could see that 254 unique links are there. My objective here is not to hardcode the highest page number to the link for iteration. Here is what I'm trying with:
Sub YifyLink()
Const link = "https://www.yify-torrent.org/search/1080p/"
Dim http As New XMLHTTP60, html As New HTMLDocument, htm As New HTMLDocument
Dim x As Long, y As Long, item_link as String
With http
.Open "GET", link, False
.send
html.body.innerHTML = .responseText
End With
For Each post In html.getElementsByClassName("pager")(0).getElementsByTagName("a")
If InStr(post.innerText, "Last") Then
x = Split(Split(post.href, "-")(1), "/")(0)
End If
Next post
For y = 0 To x
item_link = link & "t-" & y & "/"
With http
.Open "GET", item_link, False
.send
htm.body.innerHTML = .responseText
End With
For Each posts In htm.getElementsByClassName("pager")(0).getElementsByTagName("a")
I = I + 1: Cells(I, 1) = posts.href
Next posts
Next y
End Sub
Elements within which the links are:
<div class="pager">1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Next Last </div>
The results I'm getting (partial portion):
about:/search/1080p/t-20/
about:/search/1080p/t-21/
about:/search/1080p/t-22/
about:/search/1080p/t-23/
about:/search/1080p/t-255/
The idea should be to scrape pages in a loop and find something to compare, if not true, then exit loop.
This might be, i.e. checking the key against a dictionary, or checking if elements exits, or any other logic that might be specific to your problem.
For example, here your problem is, the site keeps displaying page 255 for the latter pages. So this is a clue for us. We can compare an element that belongs to page (n) with an element that belongs to page (n-1).
For instance, if element in page 256 is the same as element in page 255, then exit loop/sub. Please see the sample code below:
Sub yify()
Const mlink = "https://www.yify-torrent.org/search/1080p/t-"
Dim http As New XMLHTTP60, html As New HTMLDocument
Dim post As Object, posts As Object
Dim pageno As Long, rowno As Long
pageno = 1
rowno = 1
Do
With http
.Open "GET", mlink & pageno & "/", False
.send
html.body.innerHTML = .responseText
End With
Set posts = html.getElementsByClassName("mv")
If Cells(rowno, 1) = posts(17).getElementsByTagName("a")(0).innerText Then Exit Do
For Each post In posts
With post.getElementsByTagName("div")
If .Length Then
rowno = rowno + 1
Cells(rowno, 1) = .Item(0).innerText
End If
End With
Next post
Debug.Print "pageno: " & pageno & " completed."
pageno = pageno + 1
Loop
End Sub
I'm working on a bit of VBA that's intended to loop over a Schedule Builder for students made in Excel. I keep getting an Error 424 during the assignments c = c.Offset(X, 0), but only in the nested For loops. Is there a limited scope, and if so, how do I overcome it?
Below is the code:
Public Sub generateRosters()
Worksheets("Course Rosters").Cells.ClearContents
Worksheets("Course Rosters").Range("A1") = "Course"
Worksheets("Course Rosters").Range("B1") = "Room"
Dim classTitleRange As Range
Set classTitleRange = Worksheets("Master School Schedule").Range("D1:BN1")
Dim rowCount As Integer
rowCount = 2
Dim periodArr(1 To 8) As String
periodArr(1) = "A"
periodArr(2) = "B"
periodArr(3) = "C"
periodArr(4) = "D"
periodArr(5) = "E"
periodArr(6) = "F"
periodArr(7) = "G"
periodArr(8) = "Z"
For Each c In classTitleRange.Cells
Dim courseTitle As String
courseTitle = c
c = c.Offset(2, 0)
Dim room As String
room = c
For Each p In periodArr()
Dim offsetCount As Integer
offsetCount = 0
For i = 1 To 340
c = c.Offset(1, 0) '424 Error One
If c = p Then
End If
offsetCount = offsetCount + 1
Next
c = c.Offset(-offsetCount, 0) '424 Error Two
Next
Worksheets("Course Rosters").Range("A" & rowCount) = "'" & courseTitle
Worksheets("Course Rosters").Range("B" & rowCount) = room
rowCount = rowCount + 1
Next
End Sub
Thanks, for your help.
Edit: Side question, is there a way for me to create a variable that I can manipulate like c, but not be c. Basically a Dim d As (Something) followed by d = c. I can't seem to find the right object to assign to d, so that I can make it c. Thanks again.
I don't get logic and goal of your code therefore there are only some tips for you:
c=c.offset(2,0)
changes initial Range type c variable into empty or any other value.
Next you try to use, in the line with error, the same c variable as range object which is not allowed.
What you possibly need is the Set instruction in the following lines:
Set c= c.offset(2,0)
'....
Set c= c.offset(1,0)
But as I said, I don't know the complete logic therefore this is solution for the error you have but not sure if it solve all your problems.