Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
|
Lista Forumurilor Pe Tematici
|
Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login
POZE MRRRR'S FORUM (VIEW ONLY)
Nu sunteti logat.
|
Nou pe simpatie:
lovely_pink
 | Femeie
25 ani
Bucuresti
cauta Barbat
25 - 48 ani |
|
TonyTzu
Moderator
 Inregistrat: acum 13 ani
Postari: 252
|
|
Source:
Option 1: If you want to run this operation one time
--> Open up a new workbook.
--> Get into VBA (Press Alt+F11)
--> Insert a new module (Insert > Module)
--> Copy and Paste the Excel user defined function below
--> Press F5 and click "Run"
--> Get out of VBA (Press Alt+Q)
Sub ExtractHL()
Dim HL As Hyperlink
For Each HL In ActiveSheet.Hyperlinks
HL.Range.Offset(0, 1).Value = HL.Address
Next
End Sub
Option 2: If you plan to add more hyperlinks to the spreadsheet and need to store the formula on the sheet
--> Open up a new workbook.
--> Get into VBA (Press Alt+F11)
--> Insert a new module (Insert > Module)
--> Copy and Paste the Excel user defined function below
--> Get out of VBA (Press Alt+Q)
--> Use this syntax for this custom Excel function: =GetURL(cell,[default_value])
Function GetURL(cell As range, _
Optional default_value As Variant)
'Lists the Hyperlink Address for a Given Cell
'If cell does not contain a hyperlink, return default_value
If (cell.range("A1").Hyperlinks.Count <> 1) Then
GetURL = default_value
Else
GetURL = cell.range("A1").Hyperlinks(1).Address & "#" & cell.range("A1").Hyperlinks(1).SubAddress
End If
End Function
|
|
| pus acum 7 ani |
|
Mrrrr
AdMiN
 Inregistrat: acum 18 ani
Postari: 2251
|
|
Source:
The codes below list all hyperlinks in a worksheet / workbook. They also list all words beginning with "http" or "www".
They grab the hyperlink even if you have a hyperlink function in a cell.
They return the worksheet name in column A, cell address in column B and the hyperlink in column C.
Code for the Active Worksheet
Sub ListHyperlinksActiveSheet()
Set Asheet = ActiveSheet
Set Nsheet = Sheets.Add
Nsheet.Range("A1:C1") = Array("Worksheet", "Address", "Hyperlink")
Nsheet.Range("A1:C1").Font.Bold = True
i = 0
For Each cell In Asheet.UsedRange
On Error Resume Next
lnk = cell.Hyperlinks(1).SubAddress
If Err = 0 Then
Nsheet.Range("A2").Offset(i, 0) = Asheet.Name
Nsheet.Range("B2").Offset(i, 0) = cell.Address
Nsheet.Range("C2").Offset(i, 0) = cell.Hyperlinks(1).Address
i = i + 1
Else
If Left(cell.Formula, 11) = "=HYPERLINK(" Then
strArray = Split(cell.Formula, Chr(34))
Nsheet.Range("A2").Offset(i, 0) = Asheet.Name
Nsheet.Range("B2").Offset(i, 0) = cell.Address
Nsheet.Range("C2").Offset(i, 0) = strArray(1)
i = i + 1
Else
strArray = Split(cell)
For Each vl In strArray
If Left(vl, 4) = "http" Or Left(vl, 3) = "www" Then
Nsheet.Range("A2").Offset(i, 0) = Asheet.Name
Nsheet.Range("B2").Offset(i, 0) = cell.Address
Nsheet.Range("C2").Offset(i, 0) = vl
i = i + 1
End If
Next vl
End If
End If
On Error GoTo 0
Next cell
Nsheet.Columns("A:C").AutoFit
End Sub |
Code for the Active Workbook
Sub ListHyperlinksWBK()
Set Nsheet = Sheets.Add
Nsheet.Range("A1:C1") = Array("Worksheet", "Address", "Hyperlink")
Nsheet.Range("A1:C1").Font.Bold = True
i = 0
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> Nsheet.Name Then
For Each cell In sh.UsedRange
On Error Resume Next
lnk = cell.Hyperlinks(1).SubAddress
If Err = 0 Then
Nsheet.Range("A2").Offset(i, 0) = sh.Name
Nsheet.Range("B2").Offset(i, 0) = cell.Address
Nsheet.Range("C2").Offset(i, 0) = cell.Hyperlinks(1).Address
i = i + 1
Else
If Left(cell.Formula, 11) = "=HYPERLINK(" Then
strArray = Split(cell.Formula, Chr(34))
Nsheet.Range("A2").Offset(i, 0) = sh.Name
Nsheet.Range("B2").Offset(i, 0) = cell.Address
Nsheet.Range("C2").Offset(i, 0) = strArray(1)
i = i + 1
Else
strArray = Split(cell)
For Each vl In strArray
If Left(vl, 4) = "http" Or Left(vl, 3) = "www" Then
Nsheet.Range("A2").Offset(i, 0) = sh.Name
Nsheet.Range("B2").Offset(i, 0) = cell.Address
Nsheet.Range("C2").Offset(i, 0) = vl
i = i + 1
End If
Next vl
End If
End If
On Error GoTo 0
Next cell
End If
Next sh
Nsheet.Columns("A:C").AutoFit
End Sub
|
_______________________________________
|
|
| pus acum 5 ani |
|