代码以跳过文件扩展名,同时超链接文件

时间:2016-12-06 12:18:16

标签: excel excel-vba vba

结果还包括我不想显示的文件扩展名。如何从文本中删除文件扩展名?

Sub mymacro()
Dim objcreate As Object, objFolder As Object, objFile As Object, i As Integer
Dim ws As Worksheet, rng As Range

Set ws = Sheets("Sheet1")
Set rng = ws.Range("C1")


Set objcreate = createobject("Scripting.FileSystemObject")

Set objFolder = objcreate.GetFolder(rng)
i = 0

For Each objFile In objFolder.Files
'select cell
Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
'create hyperlink in selected cell
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
objFile.Path, _
TextToDisplay:=objFile.Name
i = i + 1
Next objFile
End Sub

2 个答案:

答案 0 :(得分:0)

只需使用LEFT功能切断最后四个字符TextToDisplay:=LEFT(objFile.Name, LEN(objFile.Name) - 4)

答案 1 :(得分:0)

你可以通过多种方式实现这一目标。之前已经回答过类似的问题:https://stackoverflow.com/a/27924854/6151782

我会尝试使用split来以不同的方式处理它。看看下面的代码:

Sub mymacro()
Dim objcreate As Object, objFolder As Object, objFile As Object, i As Integer
Dim ws As Worksheet, rng As Range

Set ws = Sheets("Sheet1")
Set rng = ws.Range("C1")


Set objcreate = createobject("Scripting.FileSystemObject")

Set objFolder = objcreate.GetFolder(rng)
i = 0

For Each objFile In objFolder.Files
'select cell
Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
'create hyperlink in selected cell
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
objFile.Path, _
TextToDisplay:=objFile.Name
tmpArr = Split(TextToDisplay,".")

Dim finalTextToDisplay
tmpArr = split(TextToDisplay,".")
finalTextToDisplay = ""

'considering there might be a dot in the file name itself, we will take the string till the last dot using loop
    loopLimit = UBound(tmpArr)
    for j=0 to loopLimit-1 
    if i = 0 then
            finalTextToDisplay = tmpArr(j)
    else
        finalTextToDisplay =tmpArr(j) & "." & finalTextToDisplay
    end if

    Next
i = i + 1
Next objFile
End Sub

在上面的代码中,我循环直到遇到最后一个点。为了避免已经落后的点,我必须设置一个if条件,以便它不会附加一个带有空白的finalTextToDisplay的点(对于第一次迭代,它将为空)。 您也可以从1开始循环并在循环之前在finalTextToDisplay中设置值以避免if条件。