0

私は自動的に行う方法を見つけようとしています

  1. 使用する名前 = 列 A の Excel セルの値でフォルダーを作成します。
  2. このフォルダへのハイパーリンクを自動的に作成します。

私のExcelワークシートのプロセスは次のとおりです

  1. 列 C にタイトルを入力します (例: C1 の値は NAME)。
  2. 次に、セル A1 は、A1 と B1 の CONCATENATE に基づいて自動入力されます (固定コンテンツ列) (例 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 に答える