troubleshooting Question

Help changes with this excel macro

Avatar of bsharath
bsharathFlag for India asked on
Microsoft OfficeMicrosoft Excel
12 Comments1 Solution387 ViewsLast Modified:
Below macro is given by Brian and it checks a URL and find if it shows results Yes/No

Can i get all the URL's that are shown below

Example
http://alturl.com/mseg7

this link shows 9 results. Can i get the Number 9 in a column and then the 9 URL's so i can check them directly (Any format is fine)



Option Explicit

Sub Check_URLS()
Dim i           As Long
Dim xResult     As String
Dim xCell       As Range
Dim xLast_Row   As Long

Sheets("Check URL's").Activate

xLast_Row = Range("A1").SpecialCells(xlLastCell).Row

If xLast_Row < 2 Then
    MsgBox ("No data found - run cancelled.")
    Exit Sub
End If

Range("B2:B" & xLast_Row).ClearContents

For Each xCell In Range("A2:A" & xLast_Row)
   
    If xCell <> "" Then
        i = i + 1
        xResult = Get_URL(xCell.Value)
    Else
        xResult = "N/A"
    End If
   
    xCell.Offset(0, 1) = xResult
   
    Application.ScreenUpdating = True
   
Next

End Sub

Function Get_URL(xUrl As String)
Dim xTempSheet  As Worksheet
Dim xConnection As String
Dim xFound      As Range

Application.ScreenUpdating = False

Set xTempSheet = Sheets.Add
xConnection = "x" & Format(Now(), "hhmmss")

On Error Resume Next

    With xTempSheet.QueryTables.Add(Connection:="URL;" & xUrl, Destination:=Range("$A$1"))
        .Name = xConnection
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

On Error GoTo 0
Dim fred
Set fred = xTempSheet.QueryTables(1)

If xTempSheet.Range("A1").SpecialCells(xlLastCell).Row = 1 Then
    Application.DisplayAlerts = False
        xTempSheet.Delete
    Application.DisplayAlerts = True
    Get_URL = "N/A"
    Exit Function
End If

Set xFound = xTempSheet.Range("A:A").Find(What:="Your search yielded no results", LookIn:=xlFormulas, LookAt:=xlPart _
                , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
       
If xFound Is Nothing Then
    Get_URL = "False"
Else
    Get_URL = "True"
End If

Application.DisplayAlerts = False
    xTempSheet.Delete
Application.DisplayAlerts = True

End Function
Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 1 Answer and 12 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 12 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros