エクセル2003 ＶＢＡでファイルのフォルダを作成

質問

会社の一覧があるのですが企業数が増えてきたのでフォルダを作成して分類しようと考えています。
一覧表には「県ごと」「２０社ごと」「１社ごと」にコードが割り振られています。
以下のようなフォルダの構成にしたいのですが、ＶＢＡによって自動的にフォルダ作成することは可能でしょうか。

zenkoku > hokkaido
　　　　　　　miyagi
　　　　　　　chiba
　　　　　　　mie
　　　　　　　kanagawa > kanagawa01 > kanagawa01A
　　　　　　　　　　・　　　　kanagawa02 > kanagawa02A
　　　　　　　　　　・　　　　　　　・　　　　　kanagawa02B
　　　　　　　　　　・
　　　　　　　　　　・

１県あたりに20社以上ある場合は、kanagawa01、kanagawa02　となっています。
元のエクセルのデータがソートされてもＯＫです。

回答No.5

mitarashi · ベストアンサー

'XMLで重複カットして、XPATHをフォルダーパスに変換したらどうかという思いつきでやってみたコードです。話の種にどうぞ。
'Microsoft XML V3.0に参照設定（もっと新しいのもありますが、大抵の環境にあるバージョン）
Dim oXMLDom As DOMDocument30
Dim fso As Object

Public Sub myMakeFolders()
Dim I As Long, j As Long, k As Long
Dim myXPath As String
Dim targetRange As Range
Dim buf As Variant
Dim root As IXMLDOMElement

Set oXMLDom = New DOMDocument30
Set fso = CreateObject("Scripting.FileSystemObject")
'初期設定
settingDOM oXMLDom
'ワークシートからリスト取得 Variant配列に収納
With ThisWorkbook.Sheets("Sheet1")
Set targetRange = .Range(.Range("D2"), .Range("D" & .Rows.Count).End(xlUp)).Resize(, 3)
End With
buf = targetRange.Value
Set root = oXMLDom.createElement("root")
oXMLDom.appendChild root
For I = 1 To UBound(buf, 2)
Call addElement(root, I, buf)
Next I
Set fso = Nothing
Set oXMLDom = Nothing
End Sub

Private Sub addElement(root As IXMLDOMElement, level As Long, buf As Variant)
Dim I As Long, j As Long
Dim parentElement As IXMLDOMElement
Dim newElement As IXMLDOMElement
Dim myXPath As String
Dim retNode As IXMLDOMNodeList
Dim folderPath As String
Dim myParentPath As String

'親フォルダーのパスを指定、デスクトップに置くとします
myParentPath = getDeskTopPath & "\zenkoku"
If Not fso.FolderExists(myParentPath) Then fso.CreateFolder myParentPath
For I = 1 To UBound(buf, 1)
myXPath = "/" & root.nodeName
For j = 1 To level - 1
If level > 1 Then myXPath = myXPath & "/" & buf(I, j)
Next j
Set parentElement = root.SelectSingleNode(myXPath)
Set retNode = root.SelectNodes(myXPath & "/" & buf(I, level))
If retNode.Length = 0 Then
Set newElement = oXMLDom.createElement(buf(I, level))
parentElement.appendChild newElement
folderPath = Replace(myXPath & "/" & buf(I, level), "/root", myParentPath)
folderPath = Replace(folderPath, "/", "\")
If Not fso.FolderExists(folderPath) Then fso.CreateFolder folderPath
End If
Next I
End Sub

'MSXMLDOMの設定
Private Sub settingDOM(ByRef dom As DOMDocument30)
With dom
.async = False
.validateOnParse = False
.resolveExternals = False
.preserveWhiteSpace = True
.setProperty "SelectionLanguage", "XPath"
End With
End Sub

Function getDeskTopPath() As String
Dim WSH As Object
Set WSH = CreateObject("Wscript.Shell")
getDeskTopPath = WSH.SpecialFolders("Desktop")
Set WSH = Nothing
End Function

お礼

回答ありがとうございます。
「話の種にどうぞ」という事でしたが、試してみたところ即解決しました。
感謝いたしております。

「追記」
ここで作成したフォルダの中にテキストファイルを格納したいと
考えております。
新たに質問させていただこうと思っております。

回答No.6

piroin654

ついでに、cmdMkFolder もフォルダの存在有無で
フォルダを作成するようにしておきます。

Sub cmdMkFolder(ByVal strPath, ByVal strDirName As String)
　　Dim obj As Object
　　Dim strFolder As String

　　Set obj = CreateObject("Scripting.FileSystemObject")
　　If Dir(strPath & "\" & strDirName, vbDirectory) = "" Then
　　　　strFolder = obj.BuildPath(strPath, strDirName)
　　　　obj.CreateFolder strFolder
　　End If

　　Set obj = Nothing
End Sub

ところで、作成したフォルダの中に
http://okwave.jp/qa/q8796473.html
でのファイルを作成するということならば、
このようにフォルダとファイルを
作成するコードを別々にするのではなく、
一つにしたコードにしたほうがいいのでは？

回答No.4

piroin654

訂正です。

　　'zenkokuというフォルダの存在確認なければ作成
　　If Dir(strPath & "\zenkoku") <> "" Then
　　Call cmdMkFolder(strPath, "zenkoku")
　　End If

のところを、

　　'zenkokuというフォルダの存在確認なければ作成
　　If Dir(strPath & "\zenkoku", vbDirectory) = "" Then
　　Call cmdMkFolder(strPath, "zenkoku")
　　Else
　　End If

のようにしてください。Dir関数の使用方法が違っていました。

お礼

回答ありがとうございます。

システムエラーです:&H80040E10(-2147217904)
という表示が出て先に進めないでいます。

ネット上で色々と調べましたが、サーバーのディスク空き容量が少ないと
この類のエラーが出るとありましたが、空き容量は60GB程あります。

回答No.3

piroin654

追加で、

ほぼ、http://okwave.jp/qa/q8796473.html
と同じですが、少しずつ変わっています。
プロシージャの名称も変えています。

なお、コードの最初のあたりのSheet名(Sheet1をSheet2とか)
conStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName
などの接続定数、たぶん　Jet.OLEDB.4.0　と、
Excel 8.0　は環境に合わせて変更してください。これは
上記のときも同じです。記載もれがありました。
(Access2003だと同じなのかな)
それと上記で、

'接続
　　myCon.Open conStr
　　'レコードセットを開く
　　rs1.Open strSQL1, myCon, adOpenStatic, adLockReadOnly
　　rs2.Open strSQL2, myCon, adOpenStatic, adLockReadOnly
　　rs3.Open strSQL2, myCon, adOpenStatic, adLockReadOnly

のところで、

　　rs3.Open strSQL2, myCon, adOpenStatic, adLockReadOnly

を
　　rs3.Open strSQL3, myCon, adOpenStatic, adLockReadOnly
としてください。変更してもしなくても同じなのですが。

お礼

あまり知識がないので自信がないのですが、
どうにか参照設定して試してみました。
システムエラーです:&H80040E10(-2147217904)
という表示が出て先に進むことができないでいます。

回答No.2

piroin654

「コードは短くなります」と言ってしまいましたが、
メインが短くならず、数行長くなったような感じです。
あえて言えば、プロシージャ二つということです。

Sub cmdMkFolder(ByVal strPath, ByVal strDirName As String)
Dim obj As Object
Dim strFolder As String

Set obj = CreateObject("Scripting.FileSystemObject")
strFolder = obj.BuildPath(strPath, strDirName)
obj.CreateFolder strFolder
Set obj = Nothing
End Sub

'ADOのレコードセットを使用
Sub testMainCmd()
　　Dim myCon As New ADODB.Connection
　　Dim FileName As String
　　Dim rs1 As New ADODB.Recordset
　　Dim rs2 As New ADODB.Recordset
　　Dim rs3 As New ADODB.Recordset
　　Dim conStr As String
　　Dim strSQL1 As String
　　Dim strSQL2 As String
　　Dim strSQL3 As String
　　Dim dic1 As Object
　　Dim dic2 As Object
　　Dim buf1 As Variant
　　Dim buf2 As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim fso As Object
　　Dim strPath As String

　　Set dic1 = CreateObject("Scripting.Dictionary")
　　Set dic2 = CreateObject("Scripting.Dictionary")

　　strSQL1 = "SELECT [県ごと] FROM [Sheet1$] GROUP BY [県ごと]"
　　strSQL2 = "SELECT * FROM [Sheet1$]"
　　strSQL3 = "SELECT * FROM [Sheet1$]"
　　'カレントフォルダ
　　strPath = ThisWorkbook.Path
　　'接続先のExcelファイル(質問の場合は現在のファイル)
　　FileName = ThisWorkbook.FullName

　　conStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
　　　　"Extended Properties=Excel 8.0;" & _
　　　　"Data Source=" & FileName

　　'接続
　　myCon.Open conStr
　　'レコードセットを開く
　　rs1.Open strSQL1, myCon, adOpenStatic, adLockReadOnly
　　rs2.Open strSQL2, myCon, adOpenStatic, adLockReadOnly
　　rs3.Open strSQL3, myCon, adOpenStatic, adLockReadOnly

　　'zenkokuというフォルダの存在確認なければ作成
　　If Dir(strPath & "\zenkoku") <> "" Then
　　Call cmdMkFolder(strPath, "zenkoku")
　　End If

　　'パスの変更
　　strPath = strPath & "\zenkoku"

　　If rs1.RecordCount > 0 Then
　　　　rs1.MoveFirst
　　　　Do Until rs1.EOF
　　　　　　If Not IsNull(rs1![県ごと]) Then
　　　　　　　　'「県ごと」のフォルダ作成
　　　　　　　　Call cmdMkFolder(strPath, rs1![県ごと])
　　　　　　　　'「20社ごと」の取得
　　　　　　　　If rs2.RecordCount > 0 Then
　　　　　　　　　　rs2.MoveFirst
　　　　　　　　　　Do Until rs2.EOF
　　　　　　　　　　　　'「県ごと」と同じ分類の「20社ごと」を検索
　　　　　　　　　　　　If rs2!県ごと = rs1![県ごと] Then
　　　　　　　　　　　　　　If Not IsNull(rs2![20社ごと]) Then
　　　　　　　　　　　　　　buf1 = rs2![20社ごと]
　　　　　　　　　　　　　　If Not dic1.exists(buf1) Then
　　　　　　　　　　　　　　　　'検索済みの「20社ごと」をDictionaryに格納
　　　　　　　　　　　　　　　　dic1.Add buf1, buf1
　　　　　　　　　　　　　　　　'「20社ごと」フォルダの作成
　　　　　　　　　　　　　　　　Call cmdMkFolder(strPath & "\" & rs1![県ごと], buf1)

　　　　　　　　　　　　　　　　'「1社ごと」の取得
　　　　　　　　　　　　　　　　rs3.MoveFirst
　　　　　　　　　　　　　　　　Do Until rs3.EOF
　　　　　　　　　　　　　　　　　　'県ごとおよび20社ごとが同じ1社ごとの検索
　　　　　　　　　　　　　　　　　　If rs2!県ごと = rs3![県ごと] And buf1 = rs3![20社ごと] Then
　　　　　　　　　　　　　　　　　　　　If Not IsNull(rs3![1社ごと]) Then
　　　　　　　　　　　　　　　　　　　　　　buf2 = rs3![1社ごと]
　　　　　　　　　　　　　　　　　　　　　　If Not dic2.exists(buf2) Then
　　　　　　　　　　　　　　　　　　　　　　　　'検索済みの「1社ごと」をDictionaryに格納
　　　　　　　　　　　　　　　　　　　　　　　　dic2.Add buf2, buf2
　　　　　　　　　　　　　　　　　　　　　　　　'「1社ごと」のフォルダの作成
　　　　　　　　　　　　　　　　　　　　　　　　Call cmdMkFolder(strPath & "\" & rs1![県ごと] & "\" & buf1, buf2)
　　　　　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　　　'変数とDictionaryの初期化
　　　　　　　　　　　　　　　　　　buf2 = ""
　　　　　　　　　　　　　　　　　　dic2.RemoveAll
　　　　　　　　　　　　　　　　'次のレコードに移動
　　　　　　　　　　　　　　　　rs3.MoveNext
　　　　　　　　　　　　　　　　Loop
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　'次のレコードに移動
　　　　　　　　　　rs2.MoveNext
　　　　　　　　　　Loop
　　　　　　　　End If
　　　　　　　　'変数とDictionaryの初期化
　　　　　　　　buf1 = ""
　　　　　　　　dic1.RemoveAll
　　　　　　End If
　　　　　　'次のレコードに移動
　　　　　　rs1.MoveNext
　　　　Loop
　　End If
　　'後始末 (オブジェクトの破棄が主)
　　rs1.Close: Set rs1 = Nothing
　　rs2.Close: Set rs2 = Nothing
　　rs3.Close: Set rs3 = Nothing
　　myCon.Close: Set myCon = Nothing
　　Set dic1 = Nothing
　　Set dic2 = Nothing
End Sub

お礼

ありがとうございます。
早速ためしてみたいと思います。

回答No.1

piroin654

http://okwave.jp/qa/q8796473.html

と、似たような方法でよければ回答しますが、
いかがですか。コードは短くなると思いますが。

お礼

回答ありがとうございます。
短いコードでおねがいいたします。