エクセルのデータからフォルダを作成

質問

エクセル選択・読み込み→フォルダ作成先指定・処理
→作成した空のフォルダを表示
という手順のプログラムです。

コモンダイアログで選んだエクセルのデータを元に、
新しいフォルダを作成したいと思っています。
エクセルには番号（一列目）、氏名（二列目）などが入っており
一人分の情報が一行目に、二人目の情報が二行目・・・という風に一行ずつに入っています。
指定した作成先に、そのエクセルで読み込んだ人数分だけ
空のフォルダを作成し、なおかつ一列目に入っていた番号を
フォルダ名にしたいのですが、どうすればいいでしょうか。
途中まで作ってみましたが後が続きません。
よろしくお願いします。

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim objShell As New Shell
Dim objFolder As Folder
Private Sub Command1_Click()

Set objShell = New Shell
Set objFolder = objShell.BrowseForFolder(Me.hWnd, "フォルダを選択してください", BIF_RETURNONLYFSDIRS)
If objFolder Is Nothing Then
MsgBox "ファイルを開く作業をキャンセルします"
Else

End If
Set objShell = Nothing
End Sub

回答No.1

stouma · ベストアンサー

'strPathはC:\Excel\Data.xlsなど
'strMakeDirはC:\Data\など(番号フォルダが作られる場所)
'
Function Excel_Date_Setting(strPath As String,strMakeDir as String)
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim Cnt As Integer

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(strPath)
Set xlSheet1 = xlBook.Worksheets("シート名")
xlApp.Visible = False

strMakeDir=iif(Right(strMakeDir,1)="\",strMakeDir,strMakeDir & "\")

With xlSheet
Cnt=1
Do While .Range("A" & Cnt)<>""
MkDir strMakeDir & .Range("A" & Cnt)
Cnt=Cnt+1
Loop
End With

xlApp.Application.Quit

'オブジェクトを開放
Set xlApp = Nothing
End Function

構文はチェックしてないのであってるか否かです。
参照設定で必ず[Microsoft Excel Object Library]にチェックをつけること
たぶんこれでいけると思いますが、エラーとか出たらすみません。大体こんなんでいけるイメージでお願いします。尚、Excelは既に開いているとまずいのでそこらのチェックはお願いします。
VB6

補足

早速の回答ありがとうございます。
stoumaさんのソースを修正し実行すると「End　Subがありません」というエラーが出てしまいます。
付け加えてちゃんと宣言しているはずなのですが

自己流のをなおしたところエラーは出ないものの実行結果が表示されません。
出来上がった空のフォルダ群を表示させるにはどうしたらよいでしょうか。
よろしければアドバイスお願いします。

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim objShell As New Shell
Dim objFolder As Folder
Private Sub Command1_Click()
Dim xlApp As EXCEL.Application
Dim xlBook As EXCEL.Workbook
Dim xlNameSheet As EXCEL.Worksheet
Dim xlFileName As String
Dim strMakeDir As String
Dim i As Integer
Dim shusseki As String
Dim rowNum As Integer
Dim objFileSystem As Object
Dim strFolderName As String
Dim stno As String

Set objShell = New Shell　　'保存先を指定させるファイル選択ダイアログ表示
Set objFolder = objShell.BrowseForFolder(Me.hWnd, "フォルダを選択してください", BIF_RETURNONLYFSDIRS)
If objFolder Is Nothing Then
MsgBox "ファイルを開く作業をキャンセルします"
Else
MsgBox objFolder.Items.Item.Path & "が選択されました"
End If
Set objShell = Nothing

xlFileName = frdFileName　'一つ前のフォームで選んだエクセルの変数（グローバル変数）
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(xlFileName)
Set xlNameSheet = xlBook.Sheets.Item(1)
xlApp.Visible = False

strMakeDir = objFolder.Items.Item.Path　'保存場所

rowNum = xlNameSheet.Range("A1").CurrentRegion.Rows.Count　'エクセルの行数を数える
For i = 1 To rowNum　'一列目の番号をフォルダ名として指定した場所に作成していく
shusseki = xlNameSheet.Cells(i, 1).Value
If IsNumeric(shusseki) Then
stno = xlNameSheet.Cells(i, 1)
strFolderName = strMakeDir & "\stno"
Set objFileSystem = CreateObject("scripting.FileSystemObject")
objFileSystem.CreateFolder (strFolderName)

Set objFileSystem = Nothing
End If
Next i
End Sub

回答No.2

kakusuke

> stno = xlNameSheet.Cells(i, 1)
stno = xlNameSheet.Cells(i, 1).Value
↑一応つけましょう

> strFolderName = strMakeDir & "\stno"
strFolderName = strMakeDir & "\" & Format(Val(stno))
↑stnoフォルダが出来るだけだと思うのですが。

> 出来上がった空のフォルダ群を表示させるにはどうしたらよいでしょうか。
Call objShell.Explore(strMakeDir)
↑エクスプローラで表示

補足

回答ありがとうございます。
ご指摘の部分を直してみましたが実行すると
選んだ保存場所だけが表示されて空フォルダは表示されません。
callの位置はあっているでしょうか？

strMakeDir = objFolder.Items.Item.Path

rowNum = xlNameSheet.Range("A1").CurrentRegion.Rows.Count
For i = 1 To rowNum
shusseki = xlNameSheet.Cells(i, 1).Value
If IsNumeric(shusseki) Then
stno = xlNameSheet.Cells(i, 1).Value
strFolderName = strMakeDir & "\" & Format(Val(stno))
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.CreateFolder (strFolderName)
Set objFileSystem = Nothing

End If
Next i
Call objShell.Explore(strMakeDir)
End Sub