?
Solved

Excel macro to check a website results

Posted on 2013-01-09
10
Medium Priority
?
376 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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
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 2000 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

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Question has a verified solution.

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

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
Microsoft has changed the look and feel of Azure AD and Microsoft account sign-in pages so that you will have a more unified look and feel when moving between the two interfaces.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…

649 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