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

我正试图找出一种方法来自动完成

创建一个文件夹，在a列中使用名称=excel单元格值

自动创建指向此文件夹的超链接 我的excel工作表上的流程如下

在C列中输入标题（示例：C1值为名称）

然后根据A1和B1（固定内容列）的连接自动填充单元格A1（示例名称_1）

此时此刻，我希望实现上述目标1和2，而不必每次都运行宏，具有以下可交付成果：

与我的工作簿位于同一目录中的新文件夹

在G列中生成一个超链接（在我们的示例中，它将在G1中） 到目前为止，我已经到了

我可以运行宏（在a列中的单元格上或a列中的区域上），这将在正确的位置生成文件夹（和子文件夹）。这是有效的：-）

然后，基于我的文件夹名称=同一行/列A中的单元格值-I只是键入=A（x）（在我们的示例A1中），我有一个宏，可以自动将其转换为指向正确位置的超链接（didcellchange-->convert to hyperlink的组合）。这也行得通

我无法将其提升到下一个级别-我真正想做的是，一旦我在C列中输入了标题，工作簿就会自动检测到C列的更改/数据输入，并且

基于列a的连接项创建文件夹

创建指向文件夹的超链接 可选择的好的（s）将是

宏实际上提供了一个选项，可以导航到文件夹应安装的位置

超链接自动正确更新到正确的位置（现在始终指向当前工作簿所在的位置-Activeworkbook.path）/或者如果某个链接回复时在指定位置找不到文件夹，则会打开一个浏览器窗口以更新到正确的文件夹位置

我怀疑这可能太复杂而无法实现。
如果有人能帮上忙，我将不胜感激——或者如果你真的认为我在这方面过于雄心勃勃，请告诉我

有什么想法吗

试试这个：

打开VBA编辑器

双击VBA项目窗口中的图纸（图纸1）（一直到左侧） -或-选择工作表（无论您的工作表名是什么，请选择它）

将以下所有代码粘贴到

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

Public blnfolder被发现为布尔值
选项显式
私有声明函数GetUserName Lib“advapi32.dll”别名“GetUserNameA”（ByVal lpBuffer为字符串，nSize为Long）为Long
函数gUsername（）作为字符串
幽幽幽幽
作为字符串的Dim strBuffer
常量dhcMaxUserName=255
strBuffer=空间（dhcMaxUserName）
lngLen=dhcMaxUserName
如果是CBool（GetUserName（strBuffer，lngLen）），那么gUsername=Left$（strBuffer，lngLen-1）
端函数
专用子工作表\u选择更改（ByVal目标作为范围）
暗尾行与长尾行相同
变暗rng As范围，c As范围
将路径设置为字符串
endRow=单元格（ActiveSheet.Rows.Count，3）.结束（xlUp）.行“”在C列中查找结束行
设置rng=范围（单元格（1，3），单元格（endRow，3））''检查C列中的每个已用单元格
对于范围内每个单元格的rng“”中的每个c
如果c.Value vbNullString和c.Hyperlinks.Count=0，则“测试以查看单元格是否为空，是否没有超链接以加快循环
单元格（c.Row，1）。值=单元格（c.Row，3）。值和“ux”&单元格（c.Row，2）。值“”连接两个值
''测试文件是否存在，如果不存在，则在上创建
currPath=ThisWorkbook.Path
如果currPath=vbNullString，则currPath=“C:\Users\”&gUsername&“\Desktop”''如果未保存文件，则将文件夹保存到桌面
folderExists currPath，单元格（c.Row，1）.Value
''如果找到文件夹，请转到下一个单元格进行检查
如果blnFolderFound=True，则转到下一步CellToCheck
''如果未找到文件夹，并且在folderExists函数中创建了一个文件夹，请添加超链接
ActiveSheet.Hyperlinks.Add锚点：=c，地址：=currPath&“\”单元格（c.Row，1）。值，TextToDisplay:=c.Value
否则：如果
nextCellToCheck：
blnFolderFound=False
下一个c
设置rng=无
端接头
函数folderExists（s_目录作为字符串，s_folderName作为字符串）
Dim obj_fso作为对象，obj_dir作为对象，obj_文件夹作为对象
设置obj_fso=CreateObject（“Scripting.FileSystemObject”）“”创建文件系统对象
设置obj_dir=obj_fso.GetFolder（s_directory）’创建文件夹对象
对于obj_目录中的每个obj_文件夹。活动工作簿文件夹中每个文件夹的子文件夹“”
如果obj_fso.folderExists（s_目录&“\”&s_folderName）=True，则blnFolderFound=True：退出“查看文件是否存在”
下一个
如果blnFolderFound=False，则obj_fso.CreateFolder（s_目录&“\”&s_folderName）’如果不存在，则创建一个
设置obj_fso=无
设置obj_dir=Nothing
端函数

---

我添加了一个条件，如果文件未保存，则保存到用户的桌面。在b列中输入要连接的值，然后在c列中输入其他值。您可能需要对此进行一些修改，以满足您的需要，但它应该为您指明正确的方向

谢谢你。如果不重新编译，这在Mac上也可以工作吗？