Print Page | Close Window

Document Hyperlinks from Pasted Text with Excel

Printed From: Roger's Access Library
Category: Other Download Libraries
Forum Name: Long, Crystal
Forum Description: Access Basics is designed for those of you with a thirst to understand the fundamentals of Access with programming in mind ... whether you realize it or not.
URL: www.rogersaccesslibrary.com/forum/forum_posts.asp?TID=615
Printed Date: 13 Dec 2017 at 7:36pm


Topic: Document Hyperlinks from Pasted Text with Excel
Posted By: Crystal Long
Subject: Document Hyperlinks from Pasted Text with Excel
Date Posted: 16 Aug 2013 at 4:42pm

Document Hyperlinks from Pasted Text with Excel


   ' Document hyperlinks in the Active Workbook
   ' to the first sheet in a new workbook (AllHyperlinks)

For instance, I copied information from a web page to an Excel worksheet so I could get data with hyperlinks.

Data with Hyperlinks to Document

  1. Create a new module in an Excel workbook
  2. Copy the code below, Compile, and Save in a macro-enabled workbook

  3. Switch to the workbook that you want to document.
  4. Run DocumentHyperlinks macro (Alt-F8)

    Run Macro in Excel

  5. Look at the results

    Results showing all hyperlinks in the workbook

When the AllHyperlinks page is created, the top row is frozen so you can always see the column labels even if you have a lot of data.

AutoFilter is also turned on so you can find information quickly.  Click on the down-arrow in any column label.  For instance, here is "TextToDisplay" for my sample data.

Filter Hyperlinks using AutoFilter



Option Explicit
'=============================================
'
'  module: mod_DocumentHyperlinks_Excel_CL
'
' LICENSE:
' This code was originally written by Crystal (strive4peace)
' strive4peace2012@yahoo.com
' August 2013
' It is not to be altered or distributed,
' except as part of a NON-COMMERCIAL application.
'
' Licensed under Creative Commons
' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0)
' This license lets you remix, tweak, and build upon your work non-commercially,
' as long as I am credited and you license your new creations under the identical terms.
' You can download and redistribute my work just like the by-nc-nd license,
' and you can also translate, make remixes, and produce new stories based on my work.
' All new work based on my work must carry the same license, so any derivatives will also be non-commercial in nature.
' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode
' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/
' ~ Crystal
' www.AccessMVP.com/strive4peace
' ~ have an awesome day :)
'=============================================

Sub DocumentHyperlinks()
' 130816 Crystal
' Creative Commons license CC BY-NC-SA 3.0

   'Purpose:
  
   'Document hyperlinks in the Active Workbook
   ' to the first sheet in a new workbook (AllHyperlinks)
  
   On Error GoTo Proc_Err
  
   Dim wbSource As Excel.Workbook _
      , shtSource As Excel.Worksheet _
      , shtTarget As Excel.Worksheet _
      , rng As Range

   Dim i As Integer _
       , nRow As Long

   Application.DisplayStatusBar = True
   Set wbSource = ActiveWorkbook

   Workbooks.Add

   Set shtTarget = ActiveWorkbook.ActiveSheet
   ' could have an error if sheet does not exist - may need to uncomment
   '   Sheets.Add

   With shtTarget
      .Name = "AllHyperlinks"
      .Cells(1, 1).Value = "Sheet"
      .Cells(1, 2).Value = "Cell"
      .Cells(1, 3).Value = "TextToDisplay"
      .Cells(1, 4).Value = "Address"
      .Cells(1, 5).Value = "SubAddress"
      .Cells(1, 7).Value = wbSource.Name

      nRow = 2

      For Each shtSource In wbSource.Sheets
        
         'If shtSource.Name = "AllHyperlinks" Then GoTo nextWorksheet

         For Each rng In shtSource.UsedRange
            Application.StatusBar = shtSource.Name & " " & rng.AddressLocal(False, False)

            If rng.Hyperlinks.Count > 0 Then
               shtTarget.Cells(nRow, 1) = shtSource.Name
               shtTarget.Cells(nRow, 2) = rng.Address(False, False)
               shtTarget.Cells(nRow, 3) = rng.Hyperlinks(1).TextToDisplay
               shtTarget.Cells(nRow, 4) = rng.Hyperlinks(1).Address
               shtTarget.Cells(nRow, 5) = rng.Hyperlinks(1).SubAddress
               nRow = nRow + 1
            End If
         Next rng

'nextWorksheet:
      Next shtSource

   End With   'shtTarget
   Call Format_AutoFilter_Freeze(shtTarget, "E")
  
Proc_Exit:
   On Error Resume Next
   Set rng = Nothing
   Set shtSource = Nothing
   Set shtTarget = Nothing
   Set wbSource = Nothing
  
   Exit Sub

Proc_Err:
   MsgBox Err.Description, , _
          "ERROR " & Err.Number _
          & "   DocumentHyperlinks by Crystal"

   Resume Proc_Exit
   Resume
End Sub

Sub Format_AutoFilter_Freeze( _
   pSht As Excel.Worksheet _
   , psLastCol As String _
   )
' 130816 Crystal
' Creative Commons license CC BY-NC-SA 3.0

   'Purpose:

   'Format the first row of the passed worksheet
   'and turn on AutoFilter
   'and freeze the top row
  
   'PARAMETERS
  
   '  pSht = reference to Excel sheet
   '  psLastCol = last column of labels (ie: "E")
     
   On Error GoTo Proc_Err
  
    With pSht
      With .Range("A1:E1")
         .Borders(xlDiagonalDown).LineStyle = xlNone
         .Borders(xlDiagonalUp).LineStyle = xlNone
         With .Borders(xlEdgeLeft)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlEdgeTop)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlEdgeBottom)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlEdgeRight)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlInsideVertical)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlInsideHorizontal)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Interior
             .Pattern = xlSolid
             .PatternColorIndex = xlAutomatic
             .ThemeColor = xlThemeColorDark1
             .TintAndShade = -0.149998474074526
             .PatternTintAndShade = 0
         End With
      End With 'label range
     
      With .Range("A2")
         .Select
         .AutoFilter
      End With
      .Cells.EntireColumn.AutoFit
   End With 'sheet
  
   ActiveWindow.FreezePanes = True
  
Proc_Exit:
   On Error Resume Next
   Exit Sub

Proc_Err:
   MsgBox Err.Description, , _
          "ERROR " & Err.Number _
          & "   Format_AutoFilter_Freeze by Crystal"

   Resume Proc_Exit
   Resume
End Sub


Warm Regards,
Crystal

Microsoft MVP
Classroom and Remote Training and Development
... Connect to me, lets build it together!

free book, tips, and tools:
http://www.AccessMVP.com/strive4peace" rel="nofollow - http://www.AccessMVP.com/strive4peace

*
(: have an awesome day :)
*



-------------
Warm Regards,
Crystal
Microsoft MVP
Remote Training & Programming
Let's Connect and Build Together

http://www.AccessMVP.com/strive4peace
http://YouTube.com/LearnAccessByCrystal
~have an awesome day ~



Print Page | Close Window