Solved

Excel macro to check a website results

Posted on 2013-01-09
10
360 Views
Last Modified: 2013-01-14
Below macro is given by Brian and it checks a URL and find if it shows results Yes/No
I want 2 changes

1. I want the macro to run but i should be able to use other open excel files in my system. As of now when this macro runs all excel are frozen and frozen i mean not accessible or usable at that time

2. The new sheet that the script created and the results placed in Column A i just want the URL once and the extraction results in "B" and column "C" the count as i get in main sheet

3. Column "D" the word we searched extracted from column "A" if possible

Example
http://alturl.com/mseg7
Attached file

Code

Option Explicit

Dim xDest As Worksheet
Dim xRows As Long

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

Set xDest = Sheets.Add
Set xSrce = Sheets("Check URL's")
xSrce.Activate

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

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

xDest.RangeRange("A1:B1") = Array("URL", "Links")
xRows = 1

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

For Each xCell In Range("A2:A" & xLast_Row)
   
    If xCell <> "" Then
        i = i + 1
        Call Get_URL(xCell)
    End If
   
    Application.ScreenUpdating = True
   
Next

End Sub

Sub Get_URL(xCell As Range)
Dim xTempSheet  As Worksheet
Dim xConnection As String
Dim xFound      As Range
Dim NextCell    As Range
Dim xHyper      As Hyperlink
Dim xUrl        As String
Dim xCount      As Long

Application.ScreenUpdating = False

xUrl = xCell

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 = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

On Error GoTo 0

If xTempSheet.Range("A1").SpecialCells(xlLastCell).Row = 1 Then
    Application.DisplayAlerts = False
        xTempSheet.Delete
    Application.DisplayAlerts = True
    xCell.Offset(0, 1) = -1
    Exit Sub
End If

'On Error Resume Next
    For Each xHyper In xTempSheet.Hyperlinks
        If xHyper.ScreenTip = "Read the rest ..." Then
            xCount = xCount + 1
            xRows = xRows + 1
            xDest.Cells(xRows, 1).Formula = "=hyperlink(""" & xUrl & """, """ & xUrl & """)"
            xDest.Cells(xRows, 2) = "=hyperlink(""" & xHyper.Name & """, """ & xHyper.Name & """)"
        End If
    Next
On Error GoTo 0

xCell.Offset(0, 1) = xCount

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

End Sub
Check-URL-s-IV.xlsm
0
Comment
Question by:bsharath
  • 6
  • 4
10 Comments
 
LVL 26

Expert Comment

by:redmondb
Comment Utility
Hi, bsharath.

1. The only solution that I'm aware of is to run a separate copy of Excel and then run the macro there.

I'm not clear what you mean by the remaining points. Could you please do a mock-up showing how you would like the file to look?

thanks,
Brian.
0
 
LVL 11

Author Comment

by:bsharath
Comment Utility
Attached file
shee1 has the results
Same format would be great

For point 1 can you explain how i do it
Check-URL-s-IV.xlsm
0
 
LVL 26

Expert Comment

by:redmondb
Comment Utility
Thanks, bsharath, I'll go through that immediately.

How do you normally start Excel (other than double-clicking a spreadsheet)?

Regards,
Brian.
0
 
LVL 26

Expert Comment

by:redmondb
Comment Utility
bsharath,

OK, my fault, I said "mock-up". What I meant was for you to manually build a sheet that looks the same as you want the macro to produce. The values in your sheet are dummy - I need real data. (Trust me that's much easier for you to provide than a detailed specification would be!)

Thanks,
Brian.
0
 
LVL 11

Author Comment

by:bsharath
Comment Utility
Sorry not sure how i missed your last message

Attached sample i need output as
Search-and-retrieve.xlsx
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 26

Accepted Solution

by:
redmondb earned 500 total points
Comment Utility
Thanks, bsharath. The other outstanding question is how you start Excel.

Please see attached. The code is...
Option Explicit

Dim xDest As Worksheet
Dim xRows As Long

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

Set xDest = Sheets.Add
Set xSrce = Sheets("Check URL's")
xSrce.Activate

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

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

xDest.Range("A1:D1") = Array("Search", "URL", "Word searched", "Count")
xRows = 1

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

Application.ScreenUpdating = False

    For Each xCell In Range("A2:A" & xLast_Row)
        
        If xCell <> "" Then
            i = i + 1
            Call Get_URL(xCell)
        End If
        
    Next

Application.ScreenUpdating = True

xDest.Cells.EntireColumn.AutoFit

End Sub

Sub Get_URL(xCell As Range)
Dim xTempSheet  As Worksheet
Dim NextCell    As Range
Dim xHyper      As Hyperlink
Dim xConnection As String
Dim xUrl        As String
Dim xSearch     As String
Dim xCount      As Long
Dim xFound      As Boolean

Application.ScreenUpdating = False

xUrl = xCell

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 = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

On Error GoTo 0

If xTempSheet.Range("A1").SpecialCells(xlLastCell).Row = 1 Then
    Application.DisplayAlerts = False
        xTempSheet.Delete
    Application.DisplayAlerts = True
    xCell.Offset(0, 1) = -1
    Exit Sub
End If

For Each xHyper In xTempSheet.Hyperlinks
    If xHyper.ScreenTip = "Read the rest ..." Then
        xCount = xCount + 1
        xRows = xRows + 1
        If xCount = 1 Then xDest.Cells(xRows, 1).Formula = "=hyperlink(""" & xUrl & """, """ & xUrl & """)"
        xDest.Cells(xRows, 2) = xHyper.Name '"=hyperlink(""" & xHyper.Name & """, """ & xHyper.Name & """)"
        xFound = True
    End If
Next

If xCount = 0 Then
    xCount = 1
    xRows = xRows + 1
    xDest.Cells(xRows, 1).Formula = "=hyperlink(""" & xUrl & """, """ & xUrl & """)"
    xCell.Offset(0, 1) = 0
Else
    xCell.Offset(0, 1) = xCount
End If

xSearch = Mid(xUrl, Len(xUrl) - InStr(1, StrReverse("/" & xUrl), "/") + 2, 9999)

xDest.Range(Cells(xRows - xCount + 1, 3).Address, Cells(xRows, 4).Address) = Array(xSearch, IIf(xFound, xCount, 0))

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

End Sub

Open in new window

Regards,
Brian.Check-URL-s-VII.xlsm
0
 
LVL 11

Author Comment

by:bsharath
Comment Utility
Thanks
I generally double click the files
Would Open from and open excel fix?

Also if the search results has more than 10 will i get all results?
Or just the first page?
0
 
LVL 26

Expert Comment

by:redmondb
Comment Utility
bsharath,

To open a separate version of Excel, load it from the Desktop, the Start Menu or the Quick Launch Bar.

Or just the first page?
Only the first page.

Brian.
0
 
LVL 11

Author Comment

by:bsharath
Comment Utility
Thank you
0
 
LVL 26

Expert Comment

by:redmondb
Comment Utility
Thanks, bsharath.
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
In this article we discuss how to recover the missing Outlook 2011 for Mac data like Emails and Contacts manually.
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now