Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!
Help changes with this excel macro
Below macro is given by Brian and it checks a URL and find if it shows results Yes/No
Can i get all the URL's that are shown below
Example
http://alturl.com/mseg7
this link shows 9 results. Can i get the Number 9 in a column and then the 9 URL's so i can check them directly (Any format is fine)
Option Explicit
Sub Check_URLS()
Dim i As Long
Dim xResult As String
Dim xCell As Range
Dim xLast_Row As Long
Sheets("Check URL's").Activate
xLast_Row = Range("A1").SpecialCells(x
If xLast_Row < 2 Then
MsgBox ("No data found - run cancelled.")
Exit Sub
End If
Range("B2:B" & xLast_Row).ClearContents
For Each xCell In Range("A2:A" & xLast_Row)
If xCell <> "" Then
i = i + 1
xResult = Get_URL(xCell.Value)
Else
xResult = "N/A"
End If
xCell.Offset(0, 1) = xResult
Application.ScreenUpdating
Next
End Sub
Function Get_URL(xUrl As String)
Dim xTempSheet As Worksheet
Dim xConnection As String
Dim xFound As Range
Application.ScreenUpdating
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 = xlWebFormattingNone
.WebPreFormattedTextToColu
.WebConsecutiveDelimitersA
.WebSingleBlockTextImport = False
.WebDisableDateRecognition
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
On Error GoTo 0
Dim fred
Set fred = xTempSheet.QueryTables(1)
If xTempSheet.Range("A1").Spe
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
Get_URL = "N/A"
Exit Function
End If
Set xFound = xTempSheet.Range("A:A").Fi
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If xFound Is Nothing Then
Get_URL = "False"
Else
Get_URL = "True"
End If
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
End Function
Can i get all the URL's that are shown below
Example
http://alturl.com/mseg7
this link shows 9 results. Can i get the Number 9 in a column and then the 9 URL's so i can check them directly (Any format is fine)
Option Explicit
Sub Check_URLS()
Dim i As Long
Dim xResult As String
Dim xCell As Range
Dim xLast_Row As Long
Sheets("Check URL's").Activate
xLast_Row = Range("A1").SpecialCells(x
If xLast_Row < 2 Then
MsgBox ("No data found - run cancelled.")
Exit Sub
End If
Range("B2:B" & xLast_Row).ClearContents
For Each xCell In Range("A2:A" & xLast_Row)
If xCell <> "" Then
i = i + 1
xResult = Get_URL(xCell.Value)
Else
xResult = "N/A"
End If
xCell.Offset(0, 1) = xResult
Application.ScreenUpdating
Next
End Sub
Function Get_URL(xUrl As String)
Dim xTempSheet As Worksheet
Dim xConnection As String
Dim xFound As Range
Application.ScreenUpdating
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 = xlWebFormattingNone
.WebPreFormattedTextToColu
.WebConsecutiveDelimitersA
.WebSingleBlockTextImport = False
.WebDisableDateRecognition
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
On Error GoTo 0
Dim fred
Set fred = xTempSheet.QueryTables(1)
If xTempSheet.Range("A1").Spe
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
Get_URL = "N/A"
Exit Function
End If
Set xFound = xTempSheet.Range("A:A").Fi
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If xFound Is Nothing Then
Get_URL = "False"
Else
Get_URL = "True"
End If
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
End Function
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Hi, bsharath.
Plerase see attached. If a page isn't found then a value of -1 is shown. The code is...
Brian.Check-URL-s-III.xlsm
Plerase see attached. If a page isn't found then a value of -1 is shown. The code is...
Option Explicit
Sub Check_URLS()
Dim i As Long
Dim xResult As String
Dim xCell As Range
Dim xLast_Row As Long
Sheets("Check URL's").Activate
xLast_Row = Range("A1").SpecialCells(xlLastCell).Row
If xLast_Row < 2 Then
MsgBox ("No data found - run cancelled.")
Exit Sub
End If
Range("B2:B" & xLast_Row).ClearContents
For Each xCell In Range("A2:A" & xLast_Row)
If xCell <> "" Then
i = i + 1
xResult = Get_URL(xCell.Value)
Else
xResult = "N/A"
End If
xCell.Offset(0, 1) = xResult
Application.ScreenUpdating = True
Next
End Sub
Function Get_URL(xUrl As String) As Long
Dim xTempSheet As Worksheet
Dim xConnection As String
Dim xFound As Range
Dim NextCell As Range
Application.ScreenUpdating = False
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 = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
On Error GoTo 0
Dim fred
Set fred = xTempSheet.QueryTables(1)
If xTempSheet.Range("A1").SpecialCells(xlLastCell).Row = 1 Then
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
Get_URL = -1
Exit Function
End If
Category:
Set xFound = xTempSheet.Range("A:A").Find(What:="Category: *", LookIn:=xlFormulas, LookAt:=xlPart _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If xFound Is Nothing Then
Get_URL = 0
Else
Set NextCell = xFound
Get_URL = 1
Do
Set NextCell = Cells.FindNext(After:=NextCell)
If Not NextCell.Address = xFound.Address Then
NextCell.Activate
Get_URL = Get_URL + 1
End If
If Not NextCell Is Nothing Then If NextCell.Address = xFound.Address Then Set NextCell = Nothing
Loop While Not NextCell Is Nothing
End If
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
End Function
Brian.Check-URL-s-III.xlsm
Thanks count works but i wanted the URL's of the results as well
Example
www.somename/word has 2 results i want the URL's of those 2 results exact page
Example
www.somename/word has 2 results i want the URL's of those 2 results exact page
bsharath,
Apologies, that was careless.
You didn't specify how you wanted the URL's displayed, so the attached is a first cut. The code is...
Brian.Check-URL-s-IV.xlsm
Apologies, that was careless.
You didn't specify how you wanted the URL's displayed, so the attached is a first cut. The code is...
Option Explicit
Sub Check_URLS()
Dim i As Long
Dim xResult As String
Dim xCell As Range
Dim xLast_Row As Long
Sheets("Check URL's").Activate
xLast_Row = Range("A1").SpecialCells(xlLastCell).Row
If xLast_Row < 2 Then
MsgBox ("No data found - run cancelled.")
Exit Sub
End If
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)
Else
xResult = "N/A"
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 xHold 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
xHold = ""
On Error Resume Next
For Each xHyper In xTempSheet.Hyperlinks
If xHyper.ScreenTip = "Read the rest ..." Then
xCount = xCount + 1
xHold = xHold & xHyper.Name & Chr(10)
End If
Next
On Error GoTo 0
xCell.Offset(0, 1) = xCount
If Len(xHold) > 0 Then xCell.Offset(0, 2) = Mid(xHold, 1, Len(xHold) - 1)
Application.DisplayAlerts = False
xTempSheet.Delete
Application.DisplayAlerts = True
End Sub
Brian.Check-URL-s-IV.xlsm
Sorry i mean "C"
Example
http://alturl.com/mseg7
row 2 to 11 i will have the URL's and then next
http://alturl.com/w5579
starts at 12th row
Example
http://alturl.com/mseg7
row 2 to 11 i will have the URL's and then next
http://alturl.com/w5579
starts at 12th row
Additional post for your help if time permits
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27980623.html
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27980623.html
bsharath,
To avoid rewriting the data in column A, is it OK if I write the data as a new sheet?
Thanks,
Brian.
To avoid rewriting the data in column A, is it OK if I write the data as a new sheet?
Thanks,
Brian.
Please attached. The code is...
Brian.Check-URL-s-IV.xlsm
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: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
Brian.Check-URL-s-IV.xlsm
Brian can you please check this related post as this
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Q_27989923.html
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Q_27989923.html
Premium Content
You need an Expert Office subscription to comment.Start Free Trial