Extract & create hyperlink of files in excel

[Manish86]

Hi,

I have thousands of files in a folder and I want to extract the part of filename and create hyperlinks. My files in a folder (microarray) look like this:
US45102950_251655210078_Feb07_1.jpg
US45102950_251655210078_Feb07_1.pdf
US45102950_251655210078_Feb07_2.jpg
US45102950_251655210078_Feb07_2.jpg

My excel file sholud look like this

US45102950 251655210078 Feb07 1 link of jpg link of pdf
US45102950 251655210078 Feb07 2 link of jpg link of pdf

Actually each file has two different extenstions like jpg and pdf but the filename is same. I want to extract the information of filename after "_" in different column and with their hyperlinks of jpg and pdf files in a single row.

I am new in VBA programming.Please help me in making the code using Macro programming in excel.

Thanks in advance

Manish

 

[losmac]

Option Explicit

'Jobs to do:
'1) Extract filenames
'2) Remove duplicates; filename for jpg & pdf extension
'3) Insert link

' !!!WARNING!!!
'Before you run procedure Jobs2Do
'In cell A1 enter "Oryginal FileName"
'In cell B1 enter "New FileName"
'In cell C1 enter "Link of jpg"
'In cell B1 enter "Link of pdf"
'It's your columnheader's; bold'em
Now, sort the range in your source sheet by column Oryginal FileName - Asc
'copy source sheet

Sub Jobs2Do()
Dim wsh As Worksheet
Dim i As Integer
Dim sOldFName As String, sNewFName As String

On Error GoTo Err_Jobs2Do

'create var of object: Worksheet
Set wsh = ThisWorkbook.Worksheets("Sh1")
i = 2 'var: counter
Do While wsh.Range("A" & i) <> "" '
sOldFName = wsh.Range("A" & i)
sNewFName = Left(sOldFName, Len(sOldFName) - 4) 'remove last 4 sighns
sNewFName = Replace(sNewFName, "_", " ") 'replace "_" with space
'insert new file name
wsh.Range("B" & i) = sNewFName
'remove duplicates
If Left(wsh.Range("A" & i + 1), Len(sOldFName) - 4) = Left((sOldFName), Len(sOldFName) - 4) Then
wsh.Range("A" & i + 1).EntireRow.Delete
End If
'extract file name without extension
sOldFName = Left(sOldFName, Len(sOldFName) - 3) 'remove extension
'insert link of jpg
InsertLink wsh.Range("C" & i), sOldFName & "jpg"
'insert link of jpg
InsertLink wsh.Range("D" & i), sOldFName & "pdf"
i = i + 1
Loop

Exit_Jobs2Do:
On Error Resume Next
Set wsh = Nothing 'free up memory
Exit Sub
Err_Jobs2Do:
Resume Exit_Jobs2Do
End Sub


Sub InsertLink(rng As Range, sFileName As String)

On Error GoTo Err_InsertLink

Worksheets(rng.Parent.Name).Hyperlinks.Add _
Anchor:=rng, Address:=sFileName, TextToDisplay:="link"

Exit_InsertLink:
Exit Sub

Err_InsertLink:
Resume Exit_InsertLink
End Sub