Sub ファイルパス一覧作成()
'≪A～E列の情報を書き込むセルとB1セルとI1をクリアし、F～H列のフォルダ分け欄は数式と値のクリアを最初に行う。ついでに、念のためそれ以外のセルもクリアする≫
Range(Cells(3, 1), Cells(Rows.Count, 5)).Clear
Cells(1, 2).Clear
Cells(1, 9).Clear
Range(Cells(3, 6), Cells(Rows.Count, 8)).ClearContents
Range(Cells(3, 9), Cells(Rows.Count, Columns.Count)).Clear
'≪取得したいフォルダをダイアログボックスを開いて選択する≫
Dim 指定フォルダのパス As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "ファイル一覧を作成したいフォルダを選択してください"
If .Show = -1 Then
指定フォルダのパス = .SelectedItems(1)
Cells(1, 2).Value = "情報を取得するフォルダ：" & 指定フォルダのパス
Else
MsgBox "中止しました。"
Exit Sub
End If
End With
'≪ファイルパス一覧を作成する≫
Dim myFSO As New FileSystemObject
Dim myRootFolder As Folder
Set myRootFolder = myFSO.GetFolder(指定フォルダのパス)
Cells(3, 1).Select 'ファイル情報を表示する最初のセルを選択する
ファイルパス書出 myRootFolder '後述の「ファイルパス書出」を呼び出して実行する。
Set myFSO = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
'≪拡張子なしのファイル名を書き込む≫
Dim objFSO As New FileSystemObject
Dim 拡張子無ファイル名 As String
Dim フルパス As String
Dim 行数 As Long
Dim 最終行 As Long
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
For 行数 = 3 To 最終行
フルパス = Cells(行数, 5).Value
拡張子無ファイル名 = objFSO.GetBaseName(フルパス)
Cells(行数, 2).Value = 拡張子無ファイル名
Next 行数
Set objFSO = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
'≪アーティスト名を書き込む≫
Dim Shell As Variant
Dim Folder As Variant
Dim 拡張子付ファイル名 As Variant
Dim フルパスその2 As Variant
Dim ファイルのフォルダパス As Variant
Dim 行数その2 As Long
Dim 最終行その2 As Long
最終行その2 = Cells(Rows.Count, 1).End(xlUp).Row
For 行数その2 = 3 To 最終行その2
拡張子付ファイル名 = Cells(行数その2, 1).Value
フルパスその2 = Cells(行数その2, 5).Value
ファイルのフォルダパス = Replace(フルパスその2, 拡張子付ファイル名, "") 'フルパスから拡張子付ファイル名を抜くようにVBAのReplace関数を使った
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(ファイルのフォルダパス)
Cells(行数その2, 3).Value = Folder.GetDetailsOf(Folder.ParseName(拡張子付ファイル名), 20) 'アーティスト名の取得(引数20番がアーティスト名)と書き込み
Next 行数その2
Set Shell = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
Set Folder = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
'≪再生用ハイパーリンクを作る≫
Dim フルパスその3 As String
Dim 行数その3 As Long
Dim 最終行その3 As Long
最終行その3 = Cells(Rows.Count, 1).End(xlUp).Row
For 行数その3 = 3 To 最終行その3
フルパスその3 = Cells(行数その3, 5).Value
ActiveSheet.Hyperlinks.Add Anchor:=Cells(行数その3, 4), Address:=フルパスその3, TextToDisplay:=Cells(行数その3, 2).Value
Next 行数その3
'≪最上段を表示した状態にしておきたいのでA3セルを選択状態にする≫
Cells(3, 1).Select
'≪最後に書き出しが完了したことをお知らせする≫
MsgBox "ファイル情報の書き出しが完了しました。"
End Sub
Sub ファイルパス書出(ByRef myParentFolder As Folder)
Dim myFolders As Folders
Dim myFolder As Folder
Dim myFiles As Files
Dim myFile As File
Set myFolders = myParentFolder.SubFolders
If myFolders.Count <> 0 Then
For Each myFolder In myFolders
ファイルパス書出 myFolder
Next myFolder
End If
Set myFiles = myParentFolder.Files
If myFiles.Count <> 0 Then
For Each myFile In myFiles
With ActiveCell
.Value = myFile.Name 'ファイル名を取得する
.Offset(0, 4) = myFile.Path 'フルパスを取得する
.Offset(1, 0).Select
End With
Next myFile
End If
End Sub
――――――――――――――――――――――――――――――――――――――‐
Sub 各曲をフォルダにコピーする()
Dim 行数 As Long
Dim 最終行 As Long
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
'≪コピー先のドライブフォルダを指定する≫
Dim 指定ドライブフォルダのパス As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "コピー先にしたいドライブフォルダを選択してください"
If .Show = -1 Then
指定ドライブフォルダのパス = .SelectedItems(1)
Cells(1, 9).Value = "コピー先ドライブフォルダ：" & 指定ドライブフォルダのパス
Else
MsgBox "中止しました。"
Exit Sub
End If
End With
'≪第1階層に「車で聞かない」が入力されたときは第2,第3階層にも「車で聞かない」を入力する≫
For 行数 = 3 To 最終行
If Cells(行数, 6).Value = "車で聞かない" Then
Cells(行数, 7).Value = "車で聞かない"
Cells(行数, 8).Value = "車で聞かない"
End If
Next 行数
'≪データコピー先のフルパスを作成する≫
Dim データコピー先のフルパス As String
Dim 第1階層のフォルダ名 As String
Dim 第2階層のフォルダ名 As String
Dim 第3階層のフォルダ名 As String
For 行数 = 3 To 最終行
第1階層のフォルダ名 = Cells(行数, 6).Value
第2階層のフォルダ名 = Cells(行数, 7).Value
第3階層のフォルダ名 = Cells(行数, 8).Value
データコピー先のフルパス = 指定ドライブフォルダのパス & "\" & 第1階層のフォルダ名 & "\" & 第2階層のフォルダ名 & "\" & 第3階層のフォルダ名 & "\" & Cells(行数, 1).Value
Cells(行数, 9).Value = データコピー先のフルパス
Next 行数
'≪フォルダを作成する≫
'第1階層のフォルダ作成
For 行数 = 3 To 最終行
If Dir(指定ドライブフォルダのパス & "\" & Cells(行数, 6).Value, vbDirectory) = "" Then
MkDir 指定ドライブフォルダのパス & "\" & Cells(行数, 6).Value
End If
Next
'第2階層のフォルダ作成
For 行数 = 3 To 最終行
If Dir(指定ドライブフォルダのパス & "\" & Cells(行数, 6).Value & "\" & Cells(行数, 7).Value, vbDirectory) = "" Then
MkDir 指定ドライブフォルダのパス & "\" & Cells(行数, 6).Value & "\" & Cells(行数, 7).Value
End If
Next
'第3階層のフォルダ作成
For 行数 = 3 To 最終行
If Dir(指定ドライブフォルダのパス & "\" & Cells(行数, 6).Value & "\" & Cells(行数, 7).Value & "\" & Cells(行数, 8).Value, vbDirectory) = "" Then
MkDir 指定ドライブフォルダのパス & "\" & Cells(行数, 6).Value & "\" & Cells(行数, 7).Value & "\" & Cells(行数, 8).Value
End If
Next
'≪音楽ファイルを指定したフォルダにコピーする≫
Dim コピー元のフルパス As String
Dim コピー先のフルパス As String
For 行数 = 3 To 最終行
コピー元のフルパス = Cells(行数, 5).Value
コピー先のフルパス = Cells(行数, 9).Value
FileCopy コピー元のフルパス, コピー先のフルパス
Next 行数
'≪コピーがきちんと行われたか確認する≫
Dim コピー先のフルパスその2 As String
For 行数 = 3 To 最終行
コピー先のフルパスその2 = Cells(行数, 9)
If Dir(コピー先のフルパス) <> "" Then
Cells(行数, 10).Value = "OK"
Else
Cells(行数, 10).Value = "NG"
End If
Next 行数
'≪全ての処理が完了したメッセージを表示する≫
MsgBox "コピーが完了しました。"
End Sub
――――――――――――――――――――――――――――――――――――――‐
こんにちは。
こんばんは。
こんにちは。
