Consulting

Results 1 to 1 of 1

Thread: Solved: Excel VBA: Screen Scrapre (I AM DESPERATE! Please Help)

  1. #1
    VBAX Regular
    Joined
    Oct 2012
    Posts
    11
    Location

    Solved: Excel VBA: Screen Scrapre (I AM DESPERATE! Please Help)

    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.

    [VBA]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[/VBA]
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •