| 
    
     |  | OSによりフォルダの位置が異なるので、適当に変更して下さい。 A列のセルにフォルダ名が抽出されます。
 
 Private Sub CommandButton1_Click()
 Dim myPath As String
 Dim myFolder As String
 Dim C As Long '行カウンタ
 
 myPath = "C:\" '検索フォルダを指定
 
 Range("A1").Value = "「" & myPath & "」のフォルダ名"
 
 C = 2
 
 myFolder = Dir(myPath, vbDirectory)
 
 Do While myFolder <> ""  '取得した名前が空欄でない間繰り返し
 
 '現在のフォルダと親フォルダでなければ
 If myFolder <> "." And myFolder <> ".." Then
 
 '取得した名前がフォルダなら
 If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
 Cells(C, 1).Value = myFolder  '取得したフォルダ名をセルに代入
 C = C + 1
 End If
 End If
 'フォルダ名を取得する
 myFolder = Dir
 Loop
 
 End Sub
 
 
 |  |