Question

我有点困境，也许有人可以提供帮助。我有一个包含许多项目名称的主文件。我想创建名称基于数字（1,2,3等）在“B”列加上每个项目名称（列“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

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

如果我在列表中的某个位置插入一个新行（即新项目），那么我将为旧的编号添加不同的编号。我不希望宏为旧项目创建新文件夹，只是因为编号不同。
调整以前创建的文件夹的名称，以匹配“B”列单元格中的新编号。
更新指向它们的超链接。

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

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

1 个答案: