基於動態單元格值（VBA）創建文件夾+超鏈接

Question

我有一點困難，也許有人可以提供幫助。我有一個包含許多項目名稱的主文件。我想從列「B」中創建名稱基於數字（1,2,3等）的文件夾，再加上從第4行開始的每個項目名稱（列「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 

現在我還需要是添加條件以下情況：

1. 如果我插入一個ne排在我列表的某處（即新項目），所以我會對舊的編號有不同的編號。我不希望宏爲舊項目創建新文件夾，只是因爲編號不同。
2. 調整先前創建的文件夾的名稱以匹配列「B」的單元格中的新編號。
3. 更新超鏈接。

Answer 1

測試，看上去OK：

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