创建文件夹&x2B；基于动态单元格值（VBA）的超链接

我有点进退两难，也许有人能帮我。我有一个主文件，其中有许多项目名称。我想创建文件夹，从第4行开始，文件夹的名称基于“B”列中的编号（1、2、3等）加上每个项目名称（F列）。另外，在“B”列的相应单元格中添加超链接。 看起来像：

Column B      Column F
1             Project 1
2             Project 2
3             Project 3

这就是我迄今为止所做的完美工作：

Sub CreateFolders()
    Application.ScreenUpdating = False
    Dim xDir As String, xNumber As String, xProjectName As String, xWholeName As String, xFullPath As String
    Dim lstrow As Long, i As Long
    Dim fso As Object

    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "F").End(xlUp).Row
    Set fso = CreateObject("Scripting.FileSystemObject")

    For i = 4 To lstrow

        xNumber = Range("B" & i).Value & "."
        xProjectName = " " & CleanName(Range("F" & i).Value)
        xWholeName = xNumber & xProjectName
        xDir = "O:\certainpath\"
        xFullPath = xDir & xWholeName

        If Not fso.FolderExists(xFullPath) Then
            fso.CreateFolder (xFullPath)
            ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & i), Address:=xFullPath

        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function CleanName(strName As String) As String 

    CleanName = Replace(strName, "/", "")
     CleanName = Replace(CleanName, """", "")
      CleanName = Replace(CleanName, "?", "")
       CleanName = Replace(CleanName, "*", "")
        CleanName = Replace(CleanName, ":", ";")
         CleanName = Replace(CleanName, "<", "")
          CleanName = Replace(CleanName, ">", "")

End Function

Sub-CreateFolders（）
Application.ScreenUpdating=False
Dim xDir作为字符串，xNumber作为字符串，xProjectName作为字符串，xWholeName作为字符串，xFullPath作为字符串
我和你一样长，我和你一样长
作为对象的Dim fso
lstrow=ActiveSheet.Cells（ActiveSheet.Rows.Count，“F”）.End（xlUp）.Row
设置fso=CreateObject（“Scripting.FileSystemObject”）
对于i=4到L行
xNumber=范围（“B”和i）.值&“
xProjectName=”“&CleanName（范围（“F”&i）.Value）
xWholeName=xNumber&xProjectName
xDir=“O:\certainpath\”
xFullPath=xDir&xWholeName
如果不是fso.FolderExists（xFullPath），那么
fso.CreateFolder（xFullPath）
ActiveSheet.Hyperlinks.Add锚定：=范围（“B”和i），地址：=xFullPath
如果结束
下一个
Application.ScreenUpdating=True
端接头
函数CleanName（strName作为字符串）作为字符串
CleanName=Replace（strName，“/”，“”）
CleanName=Replace（CleanName，“”，“”）
CleanName=Replace（CleanName，“？”，“”）
CleanName=Replace（CleanName，“*”，“”）
CleanName=Replace（CleanName，“：”，“；”）
CleanName=Replace（CleanName，“，”）
端函数

现在我还需要为以下情况添加条件：

如果我在列表中的某个位置插入新行（即新项目），则旧项目的编号将不同。我不希望宏为旧项目创建新文件夹，因为编号不同

调整以前创建的文件夹的名称，以匹配“B”列单元格中的新编号

更新指向它们的超链接

经过测试，似乎还可以：

Sub CreateFolders()
    Application.ScreenUpdating = False
    Dim xDir As String, xNumber As String, xProjectName As String
    Dim exFolder As String
    Dim xWholeName As String, xFullPath As String
    Dim lstrow As Long, i As Long, rngHL As Range


    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "F").End(xlUp).Row
    xDir = "O:\certainpath\"

    For i = 4 To lstrow

        xNumber = Range("B" & i).Value
        xProjectName = ". " & CleanName(Range("F" & i).Value)

        xWholeName = xNumber & xProjectName
        xFullPath = xDir & xWholeName

        'folder with exact name doesn't already exist?
        If Len(Dir(xFullPath, vbDirectory + vbNormal)) = 0 Then

            'no match, but is there a folder with the same project name?
            exFolder = Dir(xDir & "*" & xProjectName, vbDirectory + vbNormal)
            If Len(exFolder) > 0 Then
                'rename folder to use the new number
                Name (xDir & exFolder) As xFullPath
            Else
                'no existing project folder, so create a brand-new folder
                MkDir xFullPath
            End If

            'made a change, so add/update hyperlink
            Set rngHL = Range("B" & i)
            If rngHL.Hyperlinks.Count > 0 Then rngHL.Hyperlinks.Delete
            ActiveSheet.Hyperlinks.Add Anchor:=rngHL, Address:=xFullPath

        End If

    Next
    Application.ScreenUpdating = True
End Sub

---

项目名称是否保证是唯一的？如果是，文件夹名称中带前缀的数字的用途是什么？是，始终是唯一的。在项目名称之前编号的目的是使所有创建的文件夹以与文件中名称相同的方式排列。非常感谢，先生！它确实满足了需要。