根据单元格数据创建文件夹和子文件夹以及单元格上的超链接

Question

希望一切都好

我在许多论坛中搜索以找到解决我面临的问题的方法。我在下面描述。希望有人能帮助我。我需要以下条件的代码。首先，代码检查文件夹和子文件夹。如果不存在那么，根据单元格值 E9:E1200 创建文件夹名称，根据单元格值 I 和 H 创建子文件夹名称。如果文件夹和子文件夹存在则退出。此外，创建指向该子文件夹的超链接。

我目前正在使用下面的代码，它创建了相同的 except 子文件夹。我尝试更改它但失败了。

Sub DownArrow8_Click()
Dim Path As String
Dim Folder As String

For CheckingCells = 9 To 1200
CheckingValue = Cells(CheckingCells, 5).Value
CheckingValueAdress = Cells(CheckingCells, 5).Address

 Path = "E:. Bill\" & CheckingValue

 Folder = Dir(Path, vbDirectory)
 
 If CheckingValue = vbNullString Then
 ElseIf Folder = vbNullString Then
 VBA.FileSystem.MkDir (Path)
 Range(CheckingValueAdress).Select
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="E:. Bill\" & CheckingValue, _
 TextToDisplay:=CheckingValue
 
 Else
 Range(CheckingValueAdress).Select
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="E:. Bill\" & CheckingValue, _
 TextToDisplay:=CheckingValue

 End If
Next CheckingCells

With Range("e9:e1200").Font
 .ColorIndex = x1Automatic
 .Underline = xlUnderlineStyleNone
 .Name = "Times New Roman"
 .Size = 18
End With
End Sub

希望有人能提供帮助。

提前致谢。

Answer 1

如果您试图在不存在的文件夹中创建子文件夹，您将运行出错。您需要遍历路径，并尝试一个一个地创建每个丢失的文件夹。下面是一个函数示例：

Sub DownArrow8_Click()
    Dim Path As String
    Dim Folder As String
    
    Dim WS As Worksheet
    Set WS = ActiveSheet
    
    Dim Row As Range
    For Each Row In WS.Range("9:1200").EntireRow.Rows
        Dim CheckingCell As Range
        Set CheckingCell = Row.Cells(5)
        
        Path = "E:. Bill\" & CheckingCell.Value
        
        'Creates the folders and subfolders if they don't exist
        CreatePath Path
        
        If Not IsEmpty(CheckingCell.Value) Then
            WS.Hyperlinks.Add Anchor:=CheckingCell, Address:=Path, _
                              TextToDisplay:=CheckingCell.Value
        End If
    Next
    
    With Range("E9:E1200").Font
        .ColorIndex = x1Automatic
        .Underline = xlUnderlineStyleNone
        .Name = "Times New Roman"
        .Size = 18
    End With
End Sub

Sub CreatePath(Path As String)
    Path = Replace(Path, "/", "\")

    Dim c As Long
    For i = 0 To UBound(Split(Path, "\"))
        c = InStr(c + 1, Path, "\")
        If c = 0 Then c = Len(Path)
        CreateIfNotExist Mid(Path, 1, c)
    Next
End Sub
Sub CreateIfNotExist(Path As String)
    On Error Resume Next
    VBA.FileSystem.MkDir (Path)
    On Error GoTo 0
End Sub

根据单元格数据创建文件夹和子文件夹以及单元格上的超链接

Create Folder and subfolder along with hyperlink on cell based on cell data

directory

excel

vba

hyperlink

subdirectory