vba 自动创建文件夹和超链接

automatically create folders and hyperlinks

提问by user1557191

I am trying to figure out a way to automatically do

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

1. create a folder, with the name used = excel cell value in Column A.
2. automatically create a hyperlink to this folder.

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

The process on my excel worksheet is as follows

我的excel工作表上的流程如下

1. Enter Title in Column C (example: C1 value is NAME)
2. Then cell A1 is auto-populated based on CONCATENATE of A1 and B1 (fixed content column) (example NAME_1)

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

At this point in time, I would like to achieve goals 1 & 2 above without having to run a macro every time, with the following deliverables:

此时，我想实现上述目标 1 和 2，而不必每次都运行宏，并提供以下可交付成果：

1. a new folder located on the same directory as where my workbook is located.
2. a hyperlink is generated in Column G (in our example, it would be in G1).

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

So far I have gotten to the point of

到目前为止，我已经到了

1. I can run a macro (either on a cell in Column A, or range within Column A) and this will generate the folders (and subfolders) indeed at the right location. This works :-)
2. then, based on the fact that the name of my folder = cell value in the same row/column A - I just type =A(x) (in our example A1) and I have a macro that automatically converts this to a hyperlink to the right location (combination of didcellchange -->convert to hyperlink). This also works.

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

I cannot take it to the next level - what I really want to do is as soon as I enter a Title in Column C, automatically, the workbook detects the change/data entry to Column C and

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

1. creates a folder based on the concatenate entry of COLUMN A
2. creates a hyperlink to the folder.

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

OPTIONAL Nice-to-have(s) would be

可选的好东西是

1. the macro actually giving an option to navigate to where the folders should be installed.
2. hyperlink auto-updating correctly to the correct location (now pointing always to where the current workbook is located - Activeworkbook.path) / or if a link replies with Cannot find folder in specified location, a Browser window opens to update to the correct folder location

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

I have a suspicion that this might be too complicated to achieve.
If anybody can help with this, I would be extremely grateful - or if you indeed think that I am far too ambitious with this, let me know.

我怀疑这可能太复杂而无法实现。
如果有人能对此提供帮助，我将不胜感激 - 或者如果您确实认为我对此过于雄心勃勃，请告诉我。

Any ideas?

有任何想法吗？

回答by UberNubIsTrue

Try this:

尝试这个：

1. Open the VBA editor
2. Double click on Sheet(Sheet1) in the VBAProject Window (all the way to the left) -or- choose Sheet(WhateverYourSheetNameIsJustSelectIt)

3. Paste all of the following code in

   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
   

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
   

I added a condition to save to the user's desktop if the file has not been saved. Enter the value to concatenate in column b and then enter the other value in column c. You might have to modify this a little to fit your needs but it should get you pointed in the right direction.

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