0

我正在尝试找出一种自动执行的方法

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

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

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

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

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

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

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

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

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

可选的“锦上添花”是

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

我怀疑这可能太复杂而无法实现。
如果有人可以提供帮助,我将非常感激 - 或者如果您确实认为我在这方面过于雄心勃勃,请告诉我。

有任何想法吗?

4

1 回答 1

0

尝试这个:

  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 列中输入另一个值。您可能需要稍微修改一下以满足您的需求,但它应该让您指向正确的方向。

于 2012-07-28T01:06:50.403 回答