[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『【VBA】可変データにてフォルダ・ファイル作成をしたい』（ペコパ）
VBA初心者で恐れ入りますが質問させていただきます。
以下のような担当者別企業別販売実績表があり、
VBAで出来るかわかりませんが、出来たら下記内容を実施したいです。
可能であれば、構文もご教授いただけたら幸いです。
＜VBAでやりたいこと＞
・担当者別にフォルダを作成（フォルダ名＝担当者名）
・担当者別フォルダ内に、企業別ファイルを作成
（ファイル名＝企業名.xlsx）
・条件：担当者・企業名は、毎回変わります。
＜担当者別企業別販売実績表＞
行/A列 B列 C列 D列
1 担当者 企業名 商品 売上金額
2 北田 Aストア りんご 2,829
3 北田 Aストア ぶどう 162
4 北田 Aストア なし 1,097
5 北田 Aストア いちご 2,829
6 北田 Bストア りんご 2,829
7 北田 Bストア ぶどう 119
8 吉岡 Cストア なし 796
9 吉岡 Cストア いちご 81
10吉岡 Cストア かき 272
11吉岡 Cストア みかん 791
12吉岡 Cストア ぶどう 221
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
Dim c As Range, foln As String, fn As String
Application.ScreenUpdating = False
For Each c In Range("A2:A" & Rows.Count).SpecialCells(2)
foln = Dir(ThisWorkbook.Path & "\" & c.Value, vbDirectory)
If foln = "" Then MkDir ThisWorkbook.Path & "\" & c.Value
fn = Dir(ThisWorkbook.Path & "\" & c.Value & "\" & c.Offset(, 1).Value & ".xlsx", vbNormal)
If fn = "" Then
With Workbooks.Add
.SaveAs _
Filename:=ThisWorkbook.Path & "\" & c.Value & "\" & c.Offset(, 1).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook
.Close
End With
End If
Next c
End Sub
（mm） 2020/03/10(火) 09:39
____A______B_______C_______D__________ 1 担当者 企業名 商品 売上金額 2 北田 Aストア りんご 2,829 3 北田 Aストア ぶどう 162 4 北田 Aストア なし 1,097 5 北田 Aストア いちご 2,829 6 北田 Bストア りんご 2,829 7 北田 Bストア ぶどう 119 8 吉岡 Cストア なし 796 9 吉岡 Cストア いちご 81 10 吉岡 Cストア かき 272 11 吉岡 Cストア みかん 791 12 吉岡 Cストア ぶどう 221
↑のような表であれば、基本は↓の応用になるとおもいます。
[[20200309182736]] 『【VBA】可変条件でシートを分かる方法』（ペコパ）
そのうえで、
＞担当者別にフォルダを作成
フォルダを作成する方法はいくつかありますが、とりあえずこちらを紹介。
http://officetanaka.net/excel/vba/statement/MkDir.htm
この方法の場合、既にフォルダが存在すると実行時エラーが発生しますので、下記のようにエラースキップの手当をしたほうが良いと思います
Sub 実験03()
On Error Resume Next
MkDir ThisWorkbook.Path & "\テスト"
On Error GoTo 0
End Sub
実際のアプローチはいろいろあると思いますが
(1) 担当者・企業名 の重複しないリストを作成 (2) 新規ブックの1番目のシートを出力先シートにする (3) (1)のリストをもとに、オートフィルタで抽出 (4) (3)を(2)のシートのA1セルに貼付する (5) (4)のA2セルを見てフォルダを作成する (6) (4)の親（つまりブック）をA2セルのフォルダにB2セルの名前で保存する (7) (6)を閉じる (8) (2)～(7)を繰り返す
みたいな方法でも可能だとおもいます。
この方法の場合
(1),(3),(4),(6),(7)はマクロの記録でヒントとなるコードが得られます。 (5)は既に提示のとおり。
初めから複数の～と考えていると難しくなるとおもいますので、まずは1つだけ処理するところから考えてみませんか？
（もこな２） 2020/03/10(火) 09:57
参考に
デスクトップに担当者フォルダーを設けます。
Sub Test2()
Dim myDic As Object, d As Variant, v() As String
Dim myPath As String, my企業名 As String, file企業名 As String
Dim LastRow As Long, i As Long, c As Range
Dim objWb As Workbook
Application.ScreenUpdating = False
'デスクトップパスを取得(担当者フォルダーをデスクトップに設ける)
myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set myDic = CreateObject("Scripting.Dictionary")
With ActiveSheet
'A列の最終行を取得
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'重複のない担当者名をmyDicに格納
For Each c In .Range("A2:A" & LastRow)
my企業名 = c.Offset(, 1).Value
'myDicに担当者名の登録が有れば
If myDic.Exists(c.Value) Then
v = myDic(c.Value)
'Vに企業名の登録が無ければ登録
If IsError(Application.Match(my企業名, v, 0)) Then
ReDim Preserve v(UBound(v) + 1)
v(UBound(v)) = my企業名
myDic(c.Value) = v
End If
Else
ReDim v(0) As String
v(0) = my企業名
myDic(c.Value) = v
End If
Next
For Each d In myDic.keys
'担当者フォルダーの有無確認
If Dir(myPath & "\" & d, vbDirectory) = "" Then
'無ければ作成
MkDir myPath & "\" & d
End If
'myDicから企業名を取出し
v = myDic(d)
For i = 0 To UBound(v)
file企業名 = myPath & "\" & d & "\" & v(i) & ".xlsx"
'企業名ファイル有無確認
If Dir(file企業名) = "" Then
'無ければ作成
With Workbooks.Add
.Worksheets(1).Name = d & "_" & v(i)
.Worksheets(1).Range("A1:B1").Value = Array("商品", "売上金額")
.SaveAs file企業名
.Close
End With
End If
Set objWb = Workbooks.Open(file企業名)
.Range("A1").AutoFilter Field:=1, Criteria1:=d '担当者名で抽出
.Range("A1").AutoFilter Field:=2, Criteria1:=v(i) '企業名で抽出
.Range("C2:D" & LastRow).Copy objWb.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
objWb.Close True '上書き保存して閉じる
Next i
Next d
.AutoFilterMode = False
.Activate
End With
Set myDic = Nothing
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
（ピンク） 2020/03/10(火) 12:59
＞もこな２様
毎度ご教授いただきありがとうございます！！！
解説、とても勉強になります。
頂いたサイトと解説を参考に、自分でも構文を作れるようになりたいと思います。
とても分かりやすいサイトを教えていただき、ありがとうございました！
（ペコパ） 2020/03/11(水) 00:12
毎月、下表のような前月1か月間の販売実績表を抽出します。
＜やりたいこと＞
１、A列をキーに計上年月フォルダを作成。フォルダ名＝A列の計上年月
（抽出時は、1か月分しかないですが、毎月このマクロを実行・蓄積予定。）
２、E列をキーにT（チーム）別フォルダを作成。（フォルダ名＝E列のT名）
３、２のT（チーム）別フォルダ内に、F列をキーに各グループに属している担当者別ファイルを作成。
４、２のファイル名は、『A列の計上年月＋F列の担当者名.csv』としたい。
５、担当者別ファイルの中身は、タイトル行（1行目）＋担当者行としたい。
なお、下表は一部ですが、列はBE列まで存在します。
実績データの最終行は可変、です。（列は固定）
本番の格納場所は、共有サーバーを考えています。
A列 B列 C列 D列 E列 F列 F列 G列 H列 I列 1 計上年月 ｸﾞﾙｰﾌﾟCDｸﾞﾙｰﾌﾟ名 TCD T名 担当者CD 担当者名 管理CD 管理名 商品 2 202002 111 第一ｸﾞﾙｰﾌﾟ 11101 第一ＧAＵ 4 田中 1111111 A社 あ 3 202002 111 第一ｸﾞﾙｰﾌﾟ 11101 第一ＧAＵ 4 田中 1111111 A社 い 4 202002 111 第一ｸﾞﾙｰﾌﾟ 11102 第一ＧＢＵ 6 山田 2222222 B社 あ 5 202002 111 第一ｸﾞﾙｰﾌﾟ 11102 第一ＧＢＵ 6 山田 2222222 B社 い 6 202002 111 第一ｸﾞﾙｰﾌﾟ 11102 第一ＧＢＵ 6 山田 3333333 C社 あ 7 202002 111 第一ｸﾞﾙｰﾌﾟ 11102 第一ＧＢＵ 6 山田 3333333 C社 い 8 202002 111 第一ｸﾞﾙｰﾌﾟ 11102 第一ＧＢＵ 14 谷口 4444444 D社 あ 9 202002 111 第一ｸﾞﾙｰﾌﾟ 11102 第一ＧＢＵ 14 谷口 4444444 D社 い 10 202002 222 第二ｸﾞﾙｰﾌﾟ 43201 第二ＧＡＵ 7 鈴木 5555555 E社 あ 11 202002 222 第二ｸﾞﾙｰﾌﾟ 43201 第二ＧＡＵ 7 鈴木 5555555 E社 い 12 202002 222 第二ｸﾞﾙｰﾌﾟ 43201 第二ＧＡＵ 7 鈴木 5555555 E社 う 13 202002 222 第二ｸﾞﾙｰﾌﾟ 43250 第二ＧBＵ 2 柳 6666666 F社 え 14 202002 222 第二ｸﾞﾙｰﾌﾟ 43250 第二ＧBＵ 2 柳 6666666 F社 お 15 202002 222 第二ｸﾞﾙｰﾌﾟ 43250 第二ＧBＵ 2 柳 6666666 F社 か
（ペコパ） 2020/03/11(水) 22:54
いずれも今までもらったヒントで対応できちゃうとおもうんですが。。。。
詰まっている部分がわからないので、アドバイスができるかどうか判断ができません・・・
（もこな２） 2020/03/12(木) 00:15
コメントいつもありがとうございます。
説明不足で大変申し訳ありません。
ピンク様より頂いた構文を、条件に合うように、
変更してみたのですが、以下の記載方法がわからず、止まってしまっております。
◇A列をキーに計上年月フォルダを作成。フォルダ名＝A列の計上年月としたいのですが、
計上年月フォルダを作成してその中に格納していく方法がわかりません。
◇２のファイル名は、『A列の計上年月＋F列の担当者名.csv』としたいのですが
計上年月を追加する方法がわかりません。
◇担当者別ファイルの中身は、タイトル行（1行目）＋担当者行としたいのですが、
タイトル行を1行目だけにつける方法がわかりません。
※1行目につけられたのですが、その場合、企業ごとに
毎回タイトル行がついてしまうという現象が起こりました。
◇以下構文ではDesktop保存としていただいておりますが、共有サーバーに保存する場合、
Desktop部分を共有サーバーのフォルダパスにすればよいのでしょうか。
試しにデスクトップ以外のCドライブを取得してみましたが、その場所に格納されませんでした。
【追加】
◇ファイル名を担当者名にしておりますが、抽出データの都合上で、
担当者によって担当者名前後に空欄が入っている場合があります。
空欄があった場合は、シート名に記載する担当者名のみ、出来れば空欄をなくしたいですが、
そのようなことは可能でしょうか。※ファイルのデータは、空欄があってもそのままにしたいです。
＜記載構文＞
Sub 年月フォルダ作成担当者別ファイル作成研究用()
Dim myDic As Object, d As Variant, v() As String
Dim myPath As String, my企業名 As String, file企業名 As String
Dim LastRow As Long, i As Long, c As Range
Dim objWb As Workbook
Application.ScreenUpdating = False
'デスクトップパスを取得(担当者フォルダーをデスクトップに設ける)
myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set myDic = CreateObject("Scripting.Dictionary")
With ActiveSheet
'★条件可変'G列の最終行を取得
LastRow = .Cells(Rows.Count, "G").End(xlUp).Row
'重複のない担当者名をmyDicに格納
For Each c In .Range("G2:G" & LastRow)
'★条件可変Offset（）
my企業名 = c.Offset(, 2).Value
'myDicに担当者名の登録が有れば
If myDic.Exists(c.Value) Then
v = myDic(c.Value)
'Vに担当者名の登録が無ければ登録
If IsError(Application.Match(my担当者名, v, 0)) Then
ReDim Preserve v(UBound(v) + 1)
v(UBound(v)) = my担当者名
myDic(c.Value) = v
End If
Else
ReDim v(0) As String
v(0) = my担当者名
myDic(c.Value) = v
End If
Next
For Each d In myDic.keys
'担当者フォルダーの有無確認
If Dir(myPath & "\" & d, vbDirectory) = "" Then
'無ければ作成
MkDir myPath & "\" & d
End If
'myDicから担当者名を取出し
v = myDic(d)
For i = 0 To UBound(v)
file担当者名 = myPath & "\" & d & "\" & v(i) & ".xlsx"
'担当者名ファイル有無確認
If Dir(file担当者名) = "" Then
'無ければ作成
With Workbooks.Add
.Worksheets(1).Name = d & "_" & v(i)
'.Worksheets(1).Range("A1:B1").Value = Array("商品", "売上金額")
.SaveAs file担当者名
.Close
End With
End If
Set objWb = Workbooks.Open(file担当者名)
'★条件可変（オートフィルター）
.Range("A1").AutoFilter Field:=7, Criteria1:=d 'グループ名で抽出
.Range("A1").AutoFilter Field:=9, Criteria1:=v(i) '担当者名で抽出
.Range("A2:BE" & LastRow).Copy objWb.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
objWb.Close True '上書き保存して閉じる
Next i
Next d
.AutoFilterMode = False
.Activate
End With
Set myDic = Nothing
Application.ScreenUpdating
End Sub
（ペコパ） 2020/03/12(木) 23:37
■１
フォルダを作成する部分は既にもらっているヒントから↓のようになりませんか？
＞◇A列をキーに計上年月フォルダを作成。フォルダ名＝A列の計上年月としたいのですが、
＞ 計上年月フォルダを作成してその中に格納していく方法がわかりません。
Sub 実験01()
Dim i As Long
Stop
On Error Resume Next
MkDir "C:\売上年月"
For i = 2 To 10 Step 1
MkDir "C:\売上年月\" & Cells(i, "A").Value
Next
On Error GoTo 0
End Sub
フォルダを作成する部分は既にもらっているヒントから↑のようになりませんか？
■２
＞◇２のファイル名は、『A列の計上年月＋F列の担当者名.csv』としたいのですが
＞ 計上年月を追加する方法がわかりません。
Sub 実験02()
保存したいブック.SaveAs _
Filename:="C:\売上年月\" & 保存したいブック.Worksheets(1).Range("A2").Value & 保存したいブック.Worksheets(1).Range("F2").Value, _
FileFormat:=xlCSV
End Sub
「SaveAs」が名前を付けて保存するという命令であることはわかってますか？
（マクロの記録でも調べられます）
さらに、 Filenameの部分にファイル名（ファイルパス）、FileFormatに保存形式を指定すればよいこともマクロの記録で調べられますよ。
■３
＞◇担当者別ファイルの中身は、タイトル行（1行目）＋担当者行としたいのですが、
＞ タイトル行を1行目だけにつける方法がわかりません。
＞ ※1行目につけられたのですが、その場合、企業ごとに
＞ 毎回タイトル行がついてしまうという現象が起こりました。
これは追加条件ですね。今まで提示してないから、誰も答えてないですね。
完成後のレイアウトイメージを示してもらえませんか？
■４
＞◇以下構文ではDesktop保存としていただいておりますが、共有サーバーに保存する場合、
＞ Desktop部分を共有サーバーのフォルダパスにすればよいのでしょうか。
＞ 試しにデスクトップ以外のCドライブを取得してみましたが、その場所に格納されませんでした。
提示されたものは、デスクトップになってますよ。
ちょっと試せない環境にあるので確証はないですが、ファイルサーバーでもMkDirステートメント実行できませんか？
（SaveAsメソッドの方は大丈夫だとおもいます）
■５
＞◇ファイル名を担当者名にしておりますが、抽出データの都合上で、
＞ 担当者によって担当者名前後に空欄が入っている場合があります。
＞ 空欄があった場合は、シート名に記載する担当者名のみ、出来れば空欄をなくしたいですが、
＞ そのようなことは可能でしょうか。
＞※ファイルのデータは、空欄があってもそのままにしたいです。
とりあえず、VBAのTrim関数を使えば可能。
※のほうはできなくはないけど、いろいろめんどくさがアップするので再考をお勧めします
（もこな２） 2020/03/13(金) 07:48
（ペコパ） 2020/03/16(月) 23:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.