フォルダ名を取得するマクロとシートにある名前でフォルダを作成するマクロ

埼玉は秋晴れ
気持ちのいい朝です。

フォルダの整理によく使うマクロを載せておきます。
フォルダ名だけ同じにして中身が空のフォルダを別のフォルダに作りたい時に使います。

最初に取得したいフォルダがたくさん入っているフォルダにこのマクロファイルを置きます。 
①のマクロを回します

フォルダ名取得のシートに今あるフォルダ名の一覧が生成されます。
値をコピーして
作成するフォルダ名のシートに貼り付けます。
必要なフォルダ名以外は行削除します。
新しいフォルダを作成して、そこにこのマクロファイルを保存します。
②のマクロ回します。
新しいフォルダに、「作成するフォルダ名」のシートにあるフォルダが作成されます。

このマクロのほとんどの部分は
仕事に役立つ ExcelVBA実用サンプル 第3版 (Excel徹底活用)
渡辺ひかるさんの本を参考にしています。

今も昔もずーっとお世話になっている強ーい味方です。

♪自己責任で使ってください♪
Option Explicit

Sub ①フォルダの一覧を取得するマクロ()
'ツール⇒オプション⇒参照設定からMicrosoft Scripting Runtimeにチェックを入れる。
Dim myFso As Scripting.FileSystemObject
Dim myFolders As Scripting.Folders
Dim myFolder As Scripting.Folder

Dim Cnt As Long
Application.ScreenUpdating = False
Cnt = 2
Set myFso = New Scripting.FileSystemObject
'このマクロファイルを一覧を取得したいフォルダと同じ並びのフォルダに保存する。
'このマクロファイルと同じ階層にあるフォルダの名前を一覧で表示する。

Set myFolders = myFso.GetFolder(ThisWorkbook.Path).SubFolders
For Each myFolder In myFolders
Sheets("フォルダ名取得").Activate
Cells(Cnt, 1).Value = myFolder.Name
Cnt = Cnt + 1
Next
Columns("A:A").EntireColumn.AutoFit
Range("A1").Select
Set myFolders = Nothing 'オブジェクトの解放
Set myFso = Nothing
Application.ScreenUpdating = True
End Sub
Sub ②シートから名前を拾ってフォルダを作成するマクロ()
'ツール⇒オプション⇒参照設定からMicrosoft Scripting Runtimeにチェックを入れる。
Dim myFso As Scripting.FileSystemObject
Dim myNewName As String
Dim Atai As String
Dim Cnt As Long
Dim CntMax As Long
Cnt = 2
Sheets("作成するフォルダ名").Activate
CntMax = Cells(Rows.Count, 1).End(xlUp).Row
For Cnt = 2 To CntMax Step 1
Atai = Cells(Cnt, 1).Value
Set myFso = New Scripting.FileSystemObject
myNewName = ThisWorkbook.Path & "\" & Atai '作成するフォルダ名を指定
myFso.CreateFolder myNewName
Set myFso = Nothing 'オブジェクトの解放
Next Cnt

End Sub

ブログ気持玉

クリックして気持ちを伝えよう!

ログインしてクリックすれば、自分のブログへのリンクが付きます。

→ログインへ

なるほど(納得、参考になった、ヘー)
驚いた
面白い
ナイス
ガッツ(がんばれ!)
かわいい

気持玉数 : 0

この記事へのコメント

この記事へのトラックバック