【Youtube】poohチャンネル 「フォルダのハイパーリンクを挿入」VBA

poohチャンネル

このブログでは、Youtube の「poohチャンネル」で作成したVBAを掲載しています。

テキストで掲載していますので、VBEに貼り付けて、自身のPC用にアレンジして使用してください。

  フォルダのハイパーリンクを挿入

■セルD5のみにハイパーリンクを挿入するVBAです。

Sub InsertFolderHyperlink1()
    Dim フォルダパス As String
    Dim リンクパス As String
    
    ' フォルダパスを作成
    フォルダパス = ThisWorkbook.path & "\" & Range("C5").Value _
    & "組\" & Range("D5").Value

    ' ハイパーリンクを挿入
    Worksheets("生徒名簿").Hyperlinks.Add Anchor:=Range("D5"), _
    Address:=フォルダパス
    
End Sub

■D列すべてにハイパーリンクを挿入するVBAです。

Sub InsertFolderHyperlinks2()
    Dim フォルダパス As String
    Dim リンクパス As String
    Dim 最終行 As Long
    Dim i As Long
    
    ' 最終行を取得
    最終行 = Cells(Rows.Count, "D").End(xlUp).Row
    
    ' セルD5からD列の最終行までループ
    For i = 5 To 最終行
        ' フォルダパスを作成
        フォルダパス = ThisWorkbook.path & "\" _
        & Range("C" & i).Value & "組\" & Range("D" & i).Value

        ' ハイパーリンクを挿入
        Worksheets("生徒名簿").Hyperlinks.Add Anchor:=Range("D" & i), _
        Address:=フォルダパス
        
    Next i
    
End Sub

以前の動画のVBA

一応以前作成したVBAで、

・セルの値からフォルダを作成

・セルの値からファイルを作成

・セルの値でファイルを振り分け

のVBAについても、今回の生徒名簿用にアレンジしたものですが、掲載しておきます。

※FSOを使用していますので、参照設定⇒Microsoft Scripting Runtime の設定をお願いします。

  セルの値からフォルダを作成

Sub フォルダ作成()

    Dim FSO As New FileSystemObject
    Dim 新規フォルダ名 As String
    Dim セルの値 As Range
    
    ' B列の範囲を取得
    Dim 最終セル行 As Long
    最終セル行 = Cells(Rows.Count, 4).End(xlUp).Row
    
    ' B6から最後のセルまでのフォルダを作成
    Dim 選択セル行 As Integer
    
    For Each セルの値 In Range("D5:D" & 最終セル行)
        
        選択セル行 = セルの値.Row
        
        ' フォルダのパスを取得
        新規フォルダ名 = ThisWorkbook.path & "\" & Range("C" & 選択セル行) & "組" _
        & "\" & セルの値.Value
        
        ' フォルダを作成
        FSO.CreateFolder 新規フォルダ名
    Next セルの値
    
    ' FSOを解放
    Set FSO = Nothing
End Sub

  セルの値からファイルを作成

■新しいファイルを作成する方法

Sub 新規ファイル作成()

    Dim FSO As New FileSystemObject
    Dim ファイル名 As String
    Dim 選択セル As Range
    Dim 新しいファイル As Workbook
    
    ' D列の範囲を取得
    Dim 最終行 As Long
    最終行 = Cells(Rows.Count, 4).End(xlUp).Row
    
    ' D6から最後のセルまでのエクセルファイルを作成
    For Each 選択セル In Range("D6:D" & 最終行)
        ' ファイルのパスを取得
        ファイル名 = ThisWorkbook.path & "\" & 選択セル.Value & ".xlsx"
        
        ' 新しいブックを作成
        Set 新しいファイル = Workbooks.Add
        
        ' 新しいブックを保存
        新しいファイル.SaveAs ファイル名
        
        ' 新しいブックを閉じる
        新しいファイル.Close SaveChanges:=False
    Next 選択セル
    
    ' FSOを解放
    Set FSO = Nothing
End Sub

■ファイルのコピーを作成する方法

Sub コピーファイル作成()

    Dim FSO As New FileSystemObject
    Dim ファイル名 As String
    Dim 新しいファイル名 As String
    Dim 選択セル As Range
    Dim 新しいファイル As Workbook
    
    ' フォームの元ファイルパスを取得
    ファイル名 = ThisWorkbook.path & "\フォーム.xlsx"
    
    ' D列の範囲を取得
    Dim 最終行 As Long
    最終行 = Cells(Rows.Count, 4).End(xlUp).Row
    
    ' D6から最後のセルまでのファイルを作成
    For Each 選択セル In Range("D6:D" & 最終行)
        ' ファイル名とファイルパスを設定
        新しいファイル名 = ThisWorkbook.path & "\" & _
        選択セル.Value & ".xlsx"
        
        ' フォームのコピーを作成
        FSO.CopyFile ファイル名, 新しいファイル名

    Next 選択セル
    
    ' FSOを解放
    Set FSO = Nothing
End Sub

  セルの値でファイルを振り分け

■セルの値を基にファイルを移動

Sub ファイル移動()
    Dim FSO As New FileSystemObject
    Dim 基本パス As String
    Dim 移動先フォルダ As String
    Dim 移動ファイル名 As String
    Dim 最終行 As Long
    Dim i As Long
    
    ' ソースパスをセルC2から取得
    基本パス = ThisWorkbook.path & "\"
    
    ' 最終行をセルD列から取得
    最終行 = Sheet1.Cells(Rows.Count, "D").End(xlUp).Row
    
    ' ファイルの移動を繰り返す
    For i = 6 To 最終行
        ' 移動先フォルダをセルC2とセルBの値から取得
        移動先フォルダ = 基本パス & Sheet1.Range("C" & i).Value & "組"
        
        ' 移動するファイル名をセルD列の値から取得
        移動ファイル名 = Sheet1.Range("D" & i).Value & ".xlsx"
        
        ' ファイルの移動
        If FSO.FileExists(基本パス & 移動ファイル名) Then
            FSO.MoveFile 基本パス & 移動ファイル名, 移動先フォルダ _
            & "\" & 移動ファイル名
        End If
    Next i
    
    ' FSOのインスタンスを解放
    Set FSO = Nothing
End Sub

■ファイルのコピーをセルの値のフォルダに作成

(For Nextを使用)

Sub CopyFormFile1()
    Dim FSO As New FileSystemObject
    Dim コピーファイルパス As String
    Dim 新規ファイル名 As String
    Dim 保存先フォルダ As String
    Dim 最終行 As Long
    Dim i As Long
    Dim NewFile As Workbook
    
    
    ' ソースファイルのパスを取得
    コピーファイルパス = ThisWorkbook.path & "\" & "個別成績表.xlsx"
    
    ' 最終行をセルD列から取得
    最終行 = Sheet1.Cells(Rows.Count, "D").End(xlUp).Row
    
    ' ファイルのコピーを繰り返す
    For i = 5 To 最終行
        ' コピー元ファイル名をセルD列の値から取得
        新規ファイル名 = Sheet1.Range("D" & i).Value & ".xlsx"
        
        ' コピー先フォルダをセルC2とセルBの値から取得
        保存先フォルダ = ThisWorkbook.path & "\" & _
        Sheet1.Range("C" & i).Value & "組"
        
        ' フォームのコピーを作成
        FSO.CopyFile コピーファイルパス, 保存先フォルダ & "\" & _
        Range("D" & i).Value & "\" & 新規ファイル名
        
    Next i
    
    ' FSOのインスタンスを解放
    Set FSO = Nothing
End Sub

■ファイルのコピーをセルの値のフォルダに作成

(For Eachを使用)

Sub CopyFormFile2()
    Dim FSO As New FileSystemObject
    Dim コピーパス As String
    Dim 新規ファイル名 As String
    Dim 保存先フォルダ As String
    Dim 選択セル As Range
    Dim NewFile As Workbook
    

    ' ソースファイルのパスを取得
    コピーパス = ThisWorkbook.path & "\" & "個別成績表.xlsx"
    
    ' D6から最後のセルまでのファイルを作成
    For Each 選択セル In Range("D5:D" & Cells(Rows.Count, 4).End(xlUp).Row)
        ' コピー元ファイル名をセルD列の値から取得
        新規ファイル名 = 選択セル.Value & ".xlsx"
        
        ' コピー先フォルダをセルC2とセルBの値から取得
        保存先フォルダ = ThisWorkbook.path & "\" & _
        Range("C" & 選択セル.Row).Value & "組"
        
        ' フォームのコピーを作成
        FSO.CopyFile コピーパス, 保存先フォルダ & "\" & 新規ファイル名
        
    Next 選択セル
    
    ' FSOのインスタンスを解放
    Set FSO = Nothing
End Sub
 

以上です。

今回は、以前作成したVBAも掲載したので長くなり申し訳ございません。