Solved

Excel macro to check a website results

Posted on 2013-01-09
10
368 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 4
10 Comments
 
LVL 26

Expert Comment

by:redmondb
ID: 38759723
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
ID: 38759788
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
ID: 38759894
Thanks, bsharath, I'll go through that immediately.

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

Regards,
Brian.
0
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 
LVL 26

Expert Comment

by:redmondb
ID: 38759935
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
ID: 38771379
Sorry not sure how i missed your last message

Attached sample i need output as
Search-and-retrieve.xlsx
0
 
LVL 26

Accepted Solution

by:
redmondb earned 500 total points
ID: 38771737
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
ID: 38771744
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
ID: 38771836
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
ID: 38777166
Thank you
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38777196
Thanks, bsharath.
0

Featured Post

Salesforce Made Easy to Use

On-screen guidance at the moment of need enables you & your employees to focus on the core, you can now boost your adoption rates swiftly and simply with one easy tool.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Outlook Free & Paid Tools
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

726 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