shrivallabha
Excel Ninja
For sake of forum users who cannot download from file-sharing sites. Here's complete code.
Code:
'\\ Written : Shrivallabha S. Redij
'\\ Requirements: https://chandoo.org/forum/threads/hyperlink-and-other.36097/
Option Explicit
Public objFSO As Object
Private Sub cmdStart_Click()
'\\ Routine to Update Hyperlinks by checking files in a particular folder
Dim strFldName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select GEONAMES Folder!"
.InitialFileName = ThisWorkbook.Path
.Show
If .SelectedItems.Count > 0 Then
strFldName = .SelectedItems(1)
Else
MsgBox "No Folder Selected!", vbExclamation
Exit Sub
End If
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
ListItemsInFolder strFldName, True '\\Change Second Argument to False if you don't want to check subfolder
UpdateLinks '\\ Clean Corrupt Links which could be result of past mappings!
Set objFSO = Nothing
End Sub
Public Sub ListItemsInFolder(strPath As String, boolSubFolder As Boolean)
'\\ Routine to check files for existence and creating hyperlinks
Dim objFld As Object, objFil As Object, objSubFld As Object
Dim strName As String, strExtension As String
Dim rngFind As Range
Set objFld = objFSO.GetFolder(strPath)
For Each objFil In objFld.Files
strExtension = objFSO.GetExtensionName(objFil.Path)
If InStr(1, strExtension, "xls", vbTextCompare) > 0 Then
strName = Replace(objFil.Name, "." & strExtension, "", , , vbTextCompare)
Set rngFind = Range("D5:D" & Rows.Count).Find(strName, Range("D5"), , xlWhole)
If Not rngFind Is Nothing Then
ActiveSheet.Hyperlinks.Add Anchor:=rngFind, Address:=objFil.Path, TextToDisplay:=rngFind.Value
End If
End If
If boolSubFolder Then
For Each objSubFld In objFld.SubFolders
Call ListItemsInFolder(objSubFld.Path, True)
Next
End If
Next
End Sub
Private Sub UpdateLinks()
'\\ Clean Corrupt Links which could be result of past mappings!
Dim rng As Range
Dim HLink As Hyperlink
For Each rng In Range("D5:D" & Range("D" & Rows.Count).End(xlUp).Row)
If rng.Hyperlinks.Count > 0 Then
For Each HLink In rng.Hyperlinks
If Not objFSO.FileExists(HLink.Address) Then
rng.Hyperlinks.Delete
Exit For
End If
Next
End If
Next
End Sub
Private Sub cmdUpdateCapital_Click()
'\\ This routine updates following:
'\\ 1. Gets "Capital Name" based on "PPLC" Value in Column H
'\\ 2. Runs through Column G and H and produces counts
Dim rng As Range, rCell As Range, rngCptCol As Range, rngPPLC As Range, rngFeat As Range, rngFeCo As Range
Dim objDic As Object
Dim HLink As Hyperlink
Dim wksThis As Worksheet
Dim wbkSource As Workbook
Dim wksSource As Worksheet
Dim varKey
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare
Set wksThis = ThisWorkbook.Sheets(1)
Application.ScreenUpdating = False
For Each rng In wksThis.Range("D5:D" & wksThis.Range("D" & Rows.Count).End(xlUp).Row)
If rng.Hyperlinks.Count > 0 Then
For Each HLink In rng.Hyperlinks
If objFSO.FileExists(HLink.Address) Then
Set wbkSource = Workbooks.Open(HLink.Address)
Set wksSource = wbkSource.Sheets(1)
'\\ Update Country
Set rngCptCol = wksSource.Range("1:1").Find("FEATURE CODE", wksSource.Range("A1"), , xlWhole)
If Not rngCptCol Is Nothing Then
Set rngPPLC = rngCptCol.EntireColumn.Find("PPLC", rngCptCol, , xlWhole)
If Not rngPPLC Is Nothing Then rng.Offset(0, 5).Value = wksSource.Cells(rngPPLC.Row, "B").Value
End If
'\\ Code to update counts based on Column G
Set rngFeat = wksThis.Range("J4:R4")
Set rngCptCol = wksSource.Range("G1")
objDic.RemoveAll
For i = 2 To wksSource.Cells(wksSource.Rows.Count, rngCptCol.Column).End(xlUp).Row
If objDic.exists(wksSource.Cells(i, rngCptCol.Column).Value) Then
objDic.Item(wksSource.Cells(i, rngCptCol.Column).Value) = objDic.Item(wksSource.Cells(i, rngCptCol.Column).Value) + 1
Else
objDic.Add wksSource.Cells(i, rngCptCol.Column).Value, 1
End If
Next i
wksThis.Range("J" & rng.Row & ":R" & rng.Row).Value = 0
For Each varKey In objDic.Keys
If Len(varKey) > 0 Then
Set rCell = rngFeat.Find(varKey, , , xlWhole)
If Not rCell Is Nothing Then wksThis.Cells(rng.Row, rCell.Column).Value = objDic.Item(varKey)
End If
Next
'\\ Code to update counts based on Column H
Set rngFeCo = wksThis.Range("S4:BO4")
Set rngCptCol = wksSource.Range("H1")
objDic.RemoveAll
For i = 2 To wksSource.Cells(wksSource.Rows.Count, rngCptCol.Column).End(xlUp).Row
If objDic.exists(wksSource.Cells(i, rngCptCol.Column).Value) Then
objDic.Item(wksSource.Cells(i, rngCptCol.Column).Value) = objDic.Item(wksSource.Cells(i, rngCptCol.Column).Value) + 1
Else
objDic.Add wksSource.Cells(i, rngCptCol.Column).Value, 1
End If
Next i
wksThis.Range("S" & rng.Row & ":BO" & rng.Row).Value = 0
For Each varKey In objDic.Keys
If Len(varKey) > 0 Then
Set rCell = rngFeCo.Find(varKey, , , xlWhole)
If Not rCell Is Nothing Then wksThis.Cells(rng.Row, rCell.Column).Value = objDic.Item(varKey)
End If
Next
wbkSource.Close False
Exit For
End If
Next
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished Updating Information!", vbInformation
Set objFSO = Nothing
End Sub