將超鏈接插入到使用VBAEXCEL創建的檔案夾

下面的代碼是創建一個新檔案夾并將其命名在“A”列的名稱串列中，如果“H”列沒有“OK”，則不會創建該檔案夾。現在，我正在嘗試使它在“I”列中創建一個“DONE”訊息，該訊息超鏈接到創建的檔案夾。

Sub NewFolder()
    Dim R_EmptyLines, R_Line  As Integer

    R_EmptyLines = 0
    R_Line = 2

    
    
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String
    Dim EIposition As String
    Dim Remark_note As String
    
    
    
    
    
    While R_EmptyLines < 10
    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = UCase(Trim(Range("A" & Trim(Str(R_Line)))))
    fldrpath = "C:\TEST\FOLDER\" & fldrname
    EIposition = Range("H" & Trim(Str(R_Line)))
            If Len(fldrname) < 7 Then
               R_EmptyLines = R_EmptyLines   1
            Else
               R_EmptyLines = 0
            If EIposition = "OK" Then
                    If Not fso.FolderExists(fldrpath) Then
                    fso.createfolder (fldrpath)
   '- - - - - - - - - - - - - - - - - - - - - - - -
                    Range("I" & Trim(Str(R_Line))) = ActiveSheet.Hyperlinks.Add , Address:= _
        fldrpath, TextToDisplay:="DONE"
   '- - - - - - - - - - - - - - - - - - - - - - - -
                     End If

                 End If
                 End If
    R_Line = R_Line   1
       Wend
       
   Exit Sub
End Sub

uj5u.com熱心網友回復：

Soooo 這里可能有問題

這是您的代碼，經過重構以糾正許多錯誤和次優問題

Sub NewFolder()
    Dim R_EmptyLines As Long, R_Line As Long ' unspecified types will be Variant. No reason to use Integer.
    Dim BasePath As String ' make it easier to maintain
    Dim ws As Worksheet ' use a variable for the worksheet

    BasePath = "C:\TEST\FOLDER\"
    Set ws = ActiveSheet ' or specifiy a specific sheet
    
    R_EmptyLines = 0
    R_Line = 2
    
    Dim fso As Object
    Dim fldrName As String
    Dim fldrPath As String
    Dim EIposition As String
    
    Set fso = CreateObject("scripting.filesystemobject")
    Do While R_EmptyLines < 10 ' don'tuse to obsolete While/Wend?
        fldrName = Trim(ws.Cells(R_Line, 1).Value2) '  Cells avoid unnecassary string constructs.  Be explicit on extracting the cell value.  FSO is not case sensitive
        If Len(fldrName) < 7 Then
            R_EmptyLines = R_EmptyLines   1
        Else
            fldrPath = BasePath & fldrName
            EIposition = ws.Cells(R_Line, 8).Value2 '"H"
            R_EmptyLines = 0
            If EIposition = "OK" Then
                If Not fso.FolderExists(fldrPath) Then
                    fso.createfolder fldrPath ' No need to force evaluation of fldrPath.  Its already a value
                End If
                With ws.Cells(R_Line, 9)
                    ' if Hyperlink already exists, delete it
                    If .Hyperlinks.Count > 0 Then
                        .Hyperlinks.Delete
                    End If
                End With
                ' add hyperlink regardless of if folder already exists
                ws.Hyperlinks.Add Anchor:=ws.Cells(R_Line, 9), Address:=fldrPath, TextToDisplay:="DONE" ' If you're going to use Named Parameters, be consistent
            End If
        End If
        R_Line = R_Line   1
    Loop
End Sub

uj5u.com熱心網友回復：

最后設法使它作業。我只是錯誤地放置了范圍

If Not fso.FolderExists(fldrpath) Then
fso.createfolder (fldrpath)
ActiveSheet.Hyperlinks.Add Range("I" & Trim(Str(R_Line))), Address:=fldrpath, TextToDisplay:="DONE"
End If

標籤：擅长 vba

上一篇：檔案不斷自行重新打開

下一篇：如何在第一次打開檔案時僅自動執行一次vba宏？