自動創建文件夾和超鏈接

Question

我試圖想出一個辦法來自動完成

1. 創建一個文件夾，名爲使用= A列中Excel單元格的值
2. 自動創建超鏈接到這夾。

在我的Excel工作表的方法是如下

1. 在列輸入標題C（例如：C1值是NAME）
2. 然後單元格A1是自動填充基於A1的CONCATENATE和B1（固定含量列）（實施例NAME_1）

在這個時間點，我想實現目標1 & 2的上方，而無需宏每次運行，具有以下交付：

1. 位於與我的工作簿所在目錄相同的目錄中的新文件夾。
2. 在列G中生成超鏈接（在我們的示例中，它將在G1中）。

到目前爲止我已經得到到的

1. 我可以運行一個宏點（或者在列A中在列A的細胞，或範圍），這將產生的文件夾（和子文件夾）確實在正確的位置。這工作:-)
2. 然後，基於這樣的事實，在同一行/列中的我的文件夾=細胞值的名字 - 我只需鍵入= A（X）（在我們的例子A1），我有一個宏自動將它轉換爲超鏈接到正確的位置（didcellchange - > convert to hyperlink的組合）。這也適用。

我不能把它帶到一個新的水平 - 我真正想做的事情，只要我在C列輸入一個標題是，自動，工作簿中檢測到變化/數據錄入到C列和

1. 根據COLUMN A的連接條目創建文件夾
2. 創建超鏈接到文件夾。

可選尼斯到有（S）將

1. 宏實際上是給一個選項，導航到要安裝的文件夾。
2. 超級鏈接自動更新的正確到正確的位置（現在總是指向在當前工作簿所在 - Activeworkbook.path）/或者如果鏈路與回覆中指定位置找不到文件夾，打開瀏覽器窗口更新到正確的文件夾位置

我懷疑這可能太複雜，無法實現。
如果有人能夠幫助解決這個問題，我會非常感激 - 或者如果你確實認爲我對此太過野心，請告訴我。

任何想法？

Answer 1

試試這個：

1. 打開VBA編輯
2. 上表（工作表Sheet1）在窗口的VBAProject（一路左） 雙擊 - 或 - 選擇表（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中輸入另一個值。您可能需要稍微修改以適應您的需求，但應該讓您指出正確的方向。