xfitguru
12-08-2012, 12:10 PM
Greetings Everyone. I have been attempting this for two solid weeks (including weekends). I desperately need help. It seems like everyone on the net has had some interaction with what I am looking for but not quite enough is said or provided to help me. I am attempting to search for items on the website below:
"URL;https://www.gsaadvantage.gov/advantage/main/start_page.do"
The goal is to go into the site, look up the contractor name, and list all the items they have listed on this (every page). Is it possible to search in the site and pull this info? I have provided a workbook for assistance.
I think I am close to what I need to get this accomplished. Can someone take a look at the code below to see what I am doing wrong? Thanks and God bless.
Sub Workbook_Clean_Data()
Dim Answer As String
Dim LastMaster As Long
Answer = MsgBox("Do you want to update the data?", vbYesNo, "Update Files")
If Answer <> vbYes Then Exit Sub
LastMaster = Sheets("Master").[a1000000].End(xlUp).Row
Rows("2:" & LastMaster).Delete (xlUp)
End Sub
Sub GetTableRow()
Dim i As Long
Dim j As Long
Dim m As Long
Dim LastRow As Long
Dim NewLastMaster As Long
Dim ws As Worksheet
Dim url As String
Application.ScreenUpdating = False
Cells.Select
Selection.ClearContents
Worksheets("Master").Range("A2").Select
url = "URL; ""https://www.gsaadvantage.gov/advantage/s/search.do?db=0&searchType=1&q=0:0" & Worksheets("Original").Range("B2").Value & "&p=1"""
With ActiveSheet.QueryTables.Add(Connection:=url, Destination:=Worksheets("Master").Range("A2"))
End With
'Cleans Data
For Each ws In Worksheets
Sheets("Master").Select
If ActiveSheet.Name = "Original" Then GoTo skipsheet
If Mid(Cells(1, "D"), 1, 3) = "Buy" Or [a65536].End(xlUp).Row = 2 Then GoTo keepgoing
On Error GoTo errormsg
Cells(1, 1).Select
Cells.Find(what:="Search Results - Products", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Activate
GoTo continue
errormsg:
MsgBox "The string searched for was not found!", vbOKOnly, "Warning"
continue:
Columns("A:" & Mid(ActiveCell.Address, 2, 1)).Delete
Rows("1:" & ActiveCell.Row + 2).Delete
Columns("F:Z").Delete
LastRow = [a65536].End(xlUp).Row
For i = LastRow To 1 Step -1
If Mid(Cells(i, "A"), 1, 5) = "Disas" Or Mid(Cells(i, "A"), 1, 5) = "Indic" Then
Rows(i - 1 & ":" & i + 1).Delete
i = i - 7
End If
Next i
keepgoing:
Dim lastrow1 As Long
lastrow1 = [a65536].End(xlUp).Row
For j = lastrow1 To 1 Step -1
If Cells(j, "A").Value = "" Then Rows(j).Delete (xlUp)
If Mid(Cells(j, "A").Value, 1, 11) = "Contractor:" Then
Cells(j, "A").Value = Mid(Cells(j, "A"), 13, Len(Cells(j, "A").Value))
Cells(j, "F").Value = Cells(j - 2, "D").Value
Cells(j, "E").Value = Cells(j - 3, "D").Value
Cells(j, "B").Value = Cells(j - 4, "A").Value
Cells(j, "C").Value = Cells(j - 2, "A").Value
Cells(j, "D").Value = Cells(j - 3, "A").Value
Rows(j - 5 & ":" & j - 1).Delete (xlUp)
j = j - 5
End If
Next j
NewLastMaster = Sheets("Master").[a1000000].End(xlUp).Row + 1
Range("A1:F" & lastrow1).Copy
Sheets("Master").Activate
Cells(NewLastMaster, "A").Select
ActiveSheet.Paste
skipsheet:
Next ws
Application.ScreenUpdating = True
Sheets("Master").Activate
End Sub
"URL;https://www.gsaadvantage.gov/advantage/main/start_page.do"
The goal is to go into the site, look up the contractor name, and list all the items they have listed on this (every page). Is it possible to search in the site and pull this info? I have provided a workbook for assistance.
I think I am close to what I need to get this accomplished. Can someone take a look at the code below to see what I am doing wrong? Thanks and God bless.
Sub Workbook_Clean_Data()
Dim Answer As String
Dim LastMaster As Long
Answer = MsgBox("Do you want to update the data?", vbYesNo, "Update Files")
If Answer <> vbYes Then Exit Sub
LastMaster = Sheets("Master").[a1000000].End(xlUp).Row
Rows("2:" & LastMaster).Delete (xlUp)
End Sub
Sub GetTableRow()
Dim i As Long
Dim j As Long
Dim m As Long
Dim LastRow As Long
Dim NewLastMaster As Long
Dim ws As Worksheet
Dim url As String
Application.ScreenUpdating = False
Cells.Select
Selection.ClearContents
Worksheets("Master").Range("A2").Select
url = "URL; ""https://www.gsaadvantage.gov/advantage/s/search.do?db=0&searchType=1&q=0:0" & Worksheets("Original").Range("B2").Value & "&p=1"""
With ActiveSheet.QueryTables.Add(Connection:=url, Destination:=Worksheets("Master").Range("A2"))
End With
'Cleans Data
For Each ws In Worksheets
Sheets("Master").Select
If ActiveSheet.Name = "Original" Then GoTo skipsheet
If Mid(Cells(1, "D"), 1, 3) = "Buy" Or [a65536].End(xlUp).Row = 2 Then GoTo keepgoing
On Error GoTo errormsg
Cells(1, 1).Select
Cells.Find(what:="Search Results - Products", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Activate
GoTo continue
errormsg:
MsgBox "The string searched for was not found!", vbOKOnly, "Warning"
continue:
Columns("A:" & Mid(ActiveCell.Address, 2, 1)).Delete
Rows("1:" & ActiveCell.Row + 2).Delete
Columns("F:Z").Delete
LastRow = [a65536].End(xlUp).Row
For i = LastRow To 1 Step -1
If Mid(Cells(i, "A"), 1, 5) = "Disas" Or Mid(Cells(i, "A"), 1, 5) = "Indic" Then
Rows(i - 1 & ":" & i + 1).Delete
i = i - 7
End If
Next i
keepgoing:
Dim lastrow1 As Long
lastrow1 = [a65536].End(xlUp).Row
For j = lastrow1 To 1 Step -1
If Cells(j, "A").Value = "" Then Rows(j).Delete (xlUp)
If Mid(Cells(j, "A").Value, 1, 11) = "Contractor:" Then
Cells(j, "A").Value = Mid(Cells(j, "A"), 13, Len(Cells(j, "A").Value))
Cells(j, "F").Value = Cells(j - 2, "D").Value
Cells(j, "E").Value = Cells(j - 3, "D").Value
Cells(j, "B").Value = Cells(j - 4, "A").Value
Cells(j, "C").Value = Cells(j - 2, "A").Value
Cells(j, "D").Value = Cells(j - 3, "A").Value
Rows(j - 5 & ":" & j - 1).Delete (xlUp)
j = j - 5
End If
Next j
NewLastMaster = Sheets("Master").[a1000000].End(xlUp).Row + 1
Range("A1:F" & lastrow1).Copy
Sheets("Master").Activate
Cells(NewLastMaster, "A").Select
ActiveSheet.Paste
skipsheet:
Next ws
Application.ScreenUpdating = True
Sheets("Master").Activate
End Sub