基于动态单元格值(VBA)创建文件夹+超链接

Question

我有点进退两难，也许有人能帮忙。我有一个主文件，里面有很多项目名称。我想创建的文件夹的名称基于"B"列中的数字（1,2,3等）加上每个项目名称（"F"列），从第4行开始。此外，在列"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

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

1. 如果我在列表中的某个地方插入新行（即新项目），那么我将对旧项目使用不同的编号。我不希望宏为旧项目创建新文件夹，因为编号不同
2. 调整以前创建的文件夹的名称，以匹配列"B"单元格中的新编号
3. 更新指向它们的超链接

Answer 1

经过测试，看起来还可以：

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