Excel - 创建多个文件夹和超链接

时间:2015-07-13 10:43:10

标签: vba excel-vba excel

我想/需要在Excel工作表上选择单元格并创建文件夹(称为与单元格文本相同),并将单元格超链接到新创建的文件夹。

我已经设法找到一个为所选单元格创建文件夹的VBA,并且它们保存在与保存excel相同的位置....这样可以节省大量时间!

....但我想在VBA中添加单元格应该链接到创建的文件夹,任何人都可以帮忙吗?这是为了节省我对每个单元格的超链接。

我希望我知道如何创建这些,因为我很惊讶这看起来像我的矩阵!

下面是VBA,用于根据单元格的名称创建文件夹列表(我从论坛得到了这个):

Sub MakeFolders()

    Dim Rng As Range
    Dim maxRows, maxCols, r, c As Integer

    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count

    For c = 1 To maxCols

        r = 1
        Do While r <= maxRows

            If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then

                MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
                On Error Resume Next
            End If

            r = r + 1
        Loop

    Next c

End Sub

感谢您的帮助,请原谅我对此主题缺乏了解。

1 个答案:

答案 0 :(得分:0)

这应该可以解决问题。我用更短的版本替换了你的MakeFolders程序。

Public Sub MakeHyperlinks()

    Dim MyRange As Range
    Dim rCell As Range

    'List your folders in range A1:A4 - e.g. S:\Bartrup-CookD\Test\My New Folder 1
    Set MyRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4")

    For Each rCell In MyRange
        'Create the folder.
        CreateFolder rCell.Value

        'Create the hyperlink.
        rCell.Hyperlinks.Add Anchor:=rCell, _
                             Address:=Replace(rCell.Value, " ", "%20")

    Next rCell

End Sub

Public Sub CreateFolder(Folder)
On Error Resume Next
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Folder <> "" Then
        If Not objFSO.FileExists(objFSO.GetParentFolderName(Folder)) Then
            Call CreateFolder(objFSO.GetParentFolderName(Folder))
        End If
        objFSO.CreateFolder (Folder)
    End If
End Sub