bsharath
asked on
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(x lLastCell) .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 (Connectio n:="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
.WebPreFormattedTextToColu mns = True
.WebConsecutiveDelimitersA sOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
On Error GoTo 0
If xTempSheet.Range("A1").Spe cialCells( 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
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(x
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
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
xUrl = xCell
Set xTempSheet = Sheets.Add
xConnection = "x" & Format(Now(), "hhmmss")
On Error Resume Next
With xTempSheet.QueryTables.Add
.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
.WebPreFormattedTextToColu
.WebConsecutiveDelimitersA
.WebSingleBlockTextImport = False
.WebDisableDateRecognition
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
On Error GoTo 0
If xTempSheet.Range("A1").Spe
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
ASKER
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
shee1 has the results
Same format would be great
For point 1 can you explain how i do it
Check-URL-s-IV.xlsm
Thanks, bsharath, I'll go through that immediately.
How do you normally start Excel (other than double-clicking a spreadsheet)?
Regards,
Brian.
How do you normally start Excel (other than double-clicking a spreadsheet)?
Regards,
Brian.
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.
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.
ASKER
Sorry not sure how i missed your last message
Attached sample i need output as
Search-and-retrieve.xlsx
Attached sample i need output as
Search-and-retrieve.xlsx
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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?
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?
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.
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.
ASKER
Thank you
Thanks, 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.