自动创建文件夹和超链接

Question

我想找出一种自动执行的方法

1. 创建一个文件夹，其名称使用= A列中的excel单元格值。
2. 自动创建指向此文件夹的超链接。

我的Excel工作表上的过程如下

1. 在C列中输入标题（例如：C1值为NAME）
2. 然后基于A1和B1的CONCATENATE（固定内容列）（示例NAME_1）自动填充单元格A1

此时此刻，我想实现目标1＆amp;以上2，无需每次都运行宏，具有以下可交付成果：

1. 位于与我的工作簿所在目录相同的目录中的新文件夹。
2. 在G列中生成超链接（在我们的示例中，它将在G1中）。

到目前为止，我已经达到了

的目的
1. 我可以运行宏（在A列的单元格或A列的范围内），这将在正确的位置生成文件夹（和子文件夹）。这适用:-)
2. 然后，基于我的文件夹的名称=同一行/列A中的单元格值的事实 - 我只是键入= A（x）（在我们的示例A1中）并且我有一个宏自动将其转换为指向正确位置的超链接（didcellchange的组合 - >转换为超链接）。这也有效。

我不能把它提升到一个新的水平 - 我真正想做的是，当我在C列中输入标题时，工作簿会自动检测到C列的更改/数据输入和

1. 根据COLUMN A
的连接条目创建一个文件夹
2. 创建指向该文件夹的超链接。

OPTIONAL Nice-to-have（s）将是

1. 宏实际上提供了导航到应安装文件夹的位置的选项。
2. 超链接自动正确更新到正确的位置（现在始终指向当前工作簿所在的位置 - Activeworkbook.path）/或者如果链接在指定位置回复找不到文件夹，则会打开一个浏览器窗口以更新到正确的文件夹位置

我怀疑这可能太复杂了 如果有人可以帮忙解决这个问题，我将非常感激 - 或者如果你确实认为我对此过于雄心勃勃，请告诉我。

有什么想法吗？

Answer 1

试试这个：

1. 打开VBA编辑器
2. 双击VBAProject窗口中的Sheet（Sheet1）（一直到左边） - 或 - 选择Sheet（WhateverYourSheetNameIsJustSelectIt）

3. 将所有以下代码粘贴到

   中

   Public blnFolderFound As Boolean
   Option Explicit
   
   Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
   Function gUsername() As String
   Dim lngLen As Long
   Dim strBuffer As String
   Const dhcMaxUserName = 255
   strBuffer = Space(dhcMaxUserName)
   lngLen = dhcMaxUserName
      If CBool(GetUserName(strBuffer, lngLen)) Then gUsername = Left$(strBuffer, lngLen - 1)
   End Function
   
   
   Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim endRow As Long
   Dim rng As Range, c As Range
   Dim currPath As String
   
   endRow = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row ''Find end row in column C
   
   Set rng = Range(Cells(1, 3), Cells(endRow, 3)) ''check each used cell in column C
    For Each c In rng '' For each cell in range
      If c.Value <> vbNullString And c.Hyperlinks.Count = 0 Then  ''test to see if cell not empty and no hyperlink to speed loop up
    Cells(c.Row, 1).Value = Cells(c.Row, 3).Value & "_" & Cells(c.Row, 2).Value ''concatenate the two values
   
    ''Test to see if file exists and create on if it doesn't
     currPath = ThisWorkbook.Path
     If currPath = vbNullString Then currPath = "C:\Users\" & gUsername & "\Desktop" ''save folder to desktop if file isn't saved
       folderExists currPath, Cells(c.Row, 1).Value
   
      ''if the folder is found, move on to the next cell to check
      If blnFolderFound = True Then GoTo nextCellToCheck
   
      ''if the folder wasn't found and one was created in the folderExists function, add a hyperlink
       ActiveSheet.Hyperlinks.Add Anchor:=c, Address:=currPath & "\" & Cells(c.Row, 1).Value, TextToDisplay:=c.Value
   
   
       Else: End If
       nextCellToCheck:
       blnFolderFound = False
   Next c
   
   Set rng = Nothing
   
   
   End Sub
   
   Function folderExists(s_directory As String, s_folderName As String)
   Dim obj_fso As Object, obj_dir As Object, obj_folder As Object
   
   Set obj_fso = CreateObject("Scripting.FileSystemObject") '' create a filesystem object
   Set obj_dir = obj_fso.GetFolder(s_directory) ''create a folder object
   
   
   For Each obj_folder In obj_dir.SubFolders '' for each folder in the active workbook's folder
      If obj_fso.folderExists(s_directory & "\" & s_folderName) = True Then blnFolderFound = True: Exit For    ''see if the file exists
   Next
   
   If blnFolderFound = False Then obj_fso.CreateFolder (s_directory & "\" & s_folderName) ''if it doesn't exist create one
   
   Set obj_fso = Nothing
   Set obj_dir = Nothing
   
   End Function
   

如果文件尚未保存，我添加了保存到用户桌面的条件。输入要在列b中连接的值，然后在列c中输入另一个值。您可能需要稍微修改一下以满足您的需求，但它应该让您指向正确的方向。