[Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 378
  • Last Modified:

Excel macro to check a website results

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
bsharath
Asked:
bsharath
  • 6
  • 4
1 Solution
 
redmondbCommented:
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
 
bsharathAuthor Commented:
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
 
redmondbCommented:
Thanks, bsharath, I'll go through that immediately.

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

Regards,
Brian.
0
Restore individual SQL databases with ease

Veeam Explorer for Microsoft SQL Server delivers an easy-to-use, wizard-driven interface for restoring your databases from a backup. No expert SQL background required. Web interface provides a complete view of all available SQL databases to simplify the recovery of lost database

 
redmondbCommented:
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
 
bsharathAuthor Commented:
Sorry not sure how i missed your last message

Attached sample i need output as
Search-and-retrieve.xlsx
0
 
redmondbCommented:
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
 
bsharathAuthor Commented:
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
 
redmondbCommented:
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
 
bsharathAuthor Commented:
Thank you
0
 
redmondbCommented:
Thanks, bsharath.
0

Featured Post

Get quick recovery of individual SharePoint items

Free tool – Veeam Explorer for Microsoft SharePoint, enables fast, easy restores of SharePoint sites, documents, libraries and lists — all with no agents to manage and no additional licenses to buy.

  • 6
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now