VBAでBingo5_7
今回は「他のBookを開いて、そこからデータを読込み、またそれを閉じる。」といった流れの処理になります。
前回までは、自身のBook内で「ActiveCell」「ActiveSheet」などについて説明してきましたが、今回はさらに「ActiveWorkbook」や「ThisWorkbook」などBookに関する概念が登場しますので、Excelさんに寄り添う気持ちで読み進めてください。
また、VBAを追加したり変更したりしたときは、実行前に必ず「上書き保存する癖を付けてください。」と言っていましたが、この辺りからその意味が分かっていただけると思います。自分で開発を進めるうえで、様々なケースに遭遇すると思いますので具体的に列挙するのは難しいのですが、自身の意思とExcelさんとのずれを感じるのもこの辺りからだと思います。なので予期しない実行結果が出たときは、冷静に「保存しない」で閉じた後、再開すれば実行前の状態に戻せます。もし、上書き保存していなければ・・・。まあ何度か「イタイ経験」をしながら身に付くことなので、あまり神経質になる必要もないでしょう。
この「予期しない結果」にひとつだけ言えることは「人間の指示が正しく(適切で)ない。」「Excelさんは指示どおりに動く。」ということです。そして、そのほとんどが「ActiveCell、ActiveSheet、ActiveWorkbook」に関することです。自分は今「どのBookの、どのSheetの、どのCellに対して」処理を掛けているのか。常に意識してください。（以上、私の経験談でした。）
随分長い前置きになりましたが、そろそろ準備を始めましょう。
今回は、前回作ったフォルダ「Book」の中にフォルダ「処理済」を作ってください。
それから、前回の「Bingo5_6」で作った「B5.xlsm」を動かして「B5_xxx.xlsx」(xxxは回別)」を５～６個ほど作ってください。
そして、今回の目的である「集約.xlsm」のおおもとをフォルダ「Bingo5」の中に作ってください。（「Bingo5_1」参照）
それでは「集約.xlsm」を開いて、成作を始めます。
まずシート「操作卓」と「Form」を図のように作ってください。
シート「操作卓」は「二つの実行ボタン」と「E列の６行目から下が空白」になってさえいれば、体裁は自由にしてください。
シート「Form」は2行目B列～K列にタイトルを作るだけです。
シートデザインをしながら、今回の目標が見えて来ましたか？
今回の目標は、大きく二つあります。
目標Ⅰ：フォルダ「Book」にある、すべてのBook名を「操作卓」E列の6行目以降に書き出す。
目標Ⅱ：各Bookの内容を、それぞれのシートに取り込んで一覧表の形にする。
さあ、目標Ⅰから具体的に作っていきましょう。
今回も、フォルダ「Book」に在るBook名をひとつずつ受取る処理なので「繰り返し」の処理ではありますが、フォルダの中にいくつのBookが入っているのかExcelさんには分かりません。（人間はフォルダーを開けば、目で見て分かるのですが…）なので、今回は For to ～ Next が使えません。
そこで、
Do Until 条件
Loop
を使います。
これは「ある条件に一致するまで繰り返す」という処理です。For to の「何回」に対して、これは、「条件」によるので便利な機能です。
ここでは、条件を「Bn = ""」として「Bnが空白になるまで繰り返す」とします。
唐突で恐縮です。完成形（暫定版）を作って説明すると。
DR = ThisWorkbook.Path & "¥Book" 自身と同じ居場所(フォルダ)のフォルダ「Book」
Bn = Dir(DR & "¥B5*.xlsx") フォルダー内の任意のBook名を変数Bnに入れる（任意：B5で始まりタイプが.xlsxのもの）
Do Until Bn = "" 条件 Bnが空白になるまで
Bn = Dir() 変数Bnに次のBook名が入る
Loop Doに戻る
とすると、まずBnにフォルダ「Book」の1個目のBook名が入るので、フォルダが空でなければDoの中に入ります。
そして、Dir()で次のBook名が入るのですべてのBook名を見るまで繰り返されます。
この動きの中でやりたいことは、Book名をE列の6行目以降に書出すことなので、P=P+1で件数をカウントしながら
Cells(P+5,"E")=Bnとすれば、1件目のBook名が6行目に、2件目が7行目に…と出力されます。
これで、目標Ⅰは完成です。Procedure名を「Sub BS」などとして作って、実行ボタン「検索」と関連付けてください。
実行ボタンをクリックして、目標Ⅰの画像がでれば達成です。
ここらで、Break Timeとしましょう。
目標Ⅱの処理は、複雑なので「依頼書」の内容を考えてみましょう。
①当初処理(繰り返す前の処理)
②シート「操作卓」の6行目以降を1行読むごとにシートを作り、そのE列にあるBook名をシート名とする
③②で読んだBookを開く
④開いたBookにある全シートのデータを②で作ったシート（一覧表）に書き出す
⑤③で開いたBookを閉じる
⑥処理済みのF列に◯をつける
⑦処理済みのBookをフォルダ「処理済」に移す
⑧すべてのBookを取り込んだ後、すべてのシートに罫線を付ける
ここで、シート「操作卓」のE列の最終行を変数LRとすると6行目からLR行目までの繰り返しになるので
①の処理
For n=6 to LR
②の処理
③の処理
④の処理
⑤の処理
⑥の処理
⑦の処理
Next n となります。
⑧の処理
①の当初処理は、一つ目に自身のシート数を取得すること。
Sc = Sheets.Count
二つ目に居場所を把握してフォルダ「Book」までのPathを作ることです。
DR = ThisWorkbook.Path & "¥Book"
②のシートを作る処理は、前回のSheets("Form").Copy After:=Sheets(Sc)でできますが、その前にシート名を作っておきましょう。
シート名は、n行目のE列にあるBook名から「.xlsx」を除去したいので、変数SnとするとSn=Replace(Cells(n, "E"), ".xlsx", "")となります。
ここで注意したいことは、新しく作ったシートがActiveSheetになるのでシート「操作卓」をSelectしてActiveSheetに
戻しましょう。
③のBookオープンは初めてで重要な処理なので、まず注意事項から。
新たにオープンされたBookがActiveになります。このBookから自身のBookにデータを取り込むためには、ThisWorkbook.Sheet(任意).Cells(任意の行,列)のように「自身のBookにあるシートxx.Cellxx」とします。ここでいう自身のBookとは、処理を指示したBookつまり、当該処理のマクロを含むBookのことです。
このイメージをしっかり掴んでおかないと、既存のデータを壊してしまう事態も招きかねないので細心の注意を払ってください。
本題に戻します。オープンの構文は Workbooks.Open DR & Bn です。
DRは①で作ったPathで、Bnは各行のE列ですが、PathとBook名の間に「¥」が必要となりますのでBn="¥" & Cells(n,"E")とします。
④では、実際にデータを編集することになりますが、構文が長くなりそうなので別のProcedure「BI」を作り、Parameterとしてシート名を渡すようにすると、構文は BI Sn だけなのでスッキリします。
⑤のBookを閉じる処理は、ActiveWorkbook.Close です。
開いたBookがActiveのままなので、そのまま閉じて大丈夫です。
⑥は処理済が分かるようにシート「操作卓」のF列に○を付けておきましょう。
⑦では処理済のBookが次回の処理時に邪魔にならないように、フォルダ「処理済」に移しておきましょう。
構文は Name DR & Bn As DR & "¥処理済" & Bn となりますが、Book名を変えずにPathだけ変えることで「移動」の処理になりますので覚えて（記録して）おくと便利です。
すべてのBookについて処理が済んだ後
⑧で全シートに罫線を付けます。
これも④同様別Procedure「KL」を作り、Parameterとしてシート番号を渡すように KL ｋ としましょう。
追加した最初のシート番号をSk、最後のシート番号をScとして繰り返し構文を書くと
For k = Sk To Sc
KL k
Next k
となりますが、改行の部分を「：コロン」で区切ると
For k = Sk To Sc: KL k: Next k のように1行にまとめることもできます。
なお、追加した最初のシート番号は、①のSc = Sheets.Countの後ろに「:Sk=Sc+1」を入れておきましょう。（ここでも「：」で結合可）
ここまでで全体の流れができたので、編集の処理(Sub BI)にかかりましょう。
処理の概要としては、前回の「Bingo5_6」で編集した様式を元に戻す処理になります。このヒントを基に、暫く考えてみますか？
そうです。簡単にいうと、前回の処理の左辺と右辺を入替えれば良いのです。
ただし、読込みBookに複数あるシートを自身の1つのシートにまとめる工夫が必要です。
命題風に書くと「1シート分1～25をシートの数だけ繰り返す処理の中で、読み込んだデータを書き出す行は何行目か。ただし、1件目を3行目から書き始めるものとする」的なことでしょうか。
For s=1 to Sc
For n=1 to 25
J=n+(s-1)*25+2
Next n
Next s
罫線は「箸休め_1」を参考に「範囲」を考えてみましょう。
全体の完成コードサンプル
Sub BS() 'Book Search
LR = Cells(Rows.Count, "E").End(xlUp).Row
If LR < 6 Then LR = 6
Range("E6:F" & LR) = ""
DR = ThisWorkbook.Path & "¥Book"
Bn = Dir(DR & "¥B5*.xlsx") 'フォルダー内の1個目のBook名を取得
Do Until Bn = "" 'Bnが空白になるまで繰り返す
P = P + 1
Cells(P + 5, "E") = Bn 'セルにBook名を代入する
Bn = Dir() 'フォルダー内の次のBook名を取得
Loop
End Sub
Sub BP() 'Import
Sc = Sheets.Count: Sk = Sc + 1
DR = ThisWorkbook.Path & "¥Book"
LR = Cells(Rows.Count, "E").End(xlUp).Row
For n = 6 To LR
'** シート作成
Sn = Replace(Cells(n, "E"), ".xlsx", "") 'Book名からSheet名をつくる
Sheets("Form").Copy After:=Sheets(Sc) '最後のシートの後ろ(右)にシートをコピーする
Sheets(Sc + 1).Name = Sn '増えたシートの名前を変える
Sc = Sc + 1 'シート数をCountUP
Sheets("操作卓").Select
'** BookをOpenする
Bn = "¥" & Cells(n, "E")
Workbooks.Open DR & Bn
BI Sn '予想Import
ActiveWorkbook.Close
'** 処理済
Cells(n, "F") = "○" '処理済Flag
Name DR & Bn As DR & "¥処理済" & Bn 'Bookのフォルダ移動
Next
'** 最終処理
For k = Sk To Sc: KL k: Next k '追加シートに罫線を引く
Sheets("操作卓").Select
End Sub
Sub BI(Sn) 'Bingo様式をListに編集する
Sc = Sheets.Count '開いたBookのシート数
For s = 1 To Sc
For n = 1 To 25
a = Fix((n - 1) / 5) * 4 + 5 '出力基準行番号計算
b = ((n - Fix((n - 1) / 5) * 5) - 1) * 4 + 3 '出力基準列番号計算
J = n + (s - 1) * 25 + 2
ThisWorkbook.Sheets(Sn).Cells(J, "C") = Sheets(s).Cells(a - 1, b - 1) '基準点の1行上のひとつ左の列にⅠの値
ThisWorkbook.Sheets(Sn).Cells(J, "D") = Sheets(s).Cells(a - 1, b) '基準点の1行上の同じ列にⅡの値
ThisWorkbook.Sheets(Sn).Cells(J, "E") = Sheets(s).Cells(a - 1, b + 1) '基準点の1行上のひとつ右の列にⅢの値
ThisWorkbook.Sheets(Sn).Cells(J, "F") = Sheets(s).Cells(a, b - 1) '基準点の同じ行のひとつ左の列にⅣの値
ThisWorkbook.Sheets(Sn).Cells(J, "B") = Sheets(s).Cells(a, b) '基準点にSETの値
ThisWorkbook.Sheets(Sn).Cells(J, "G") = Sheets(s).Cells(a, b + 1) '基準点の同じ行のひとつ右の列にⅤの値
ThisWorkbook.Sheets(Sn).Cells(J, "H") = Sheets(s).Cells(a + 1, b - 1) '基準点の1行下のひとつ左の列にⅥの値
ThisWorkbook.Sheets(Sn).Cells(J, "I") = Sheets(s).Cells(a + 1, b) '基準点の1行下の同じ列にⅦの値
ThisWorkbook.Sheets(Sn).Cells(J, "J") = Sheets(s).Cells(a + 1, b + 1) '基準点の1行下のひとつ右の列にⅧの値
ThisWorkbook.Sheets(Sn).Cells(J, "K") = Sheets(s).Name 'シート名
Next n
Next s
End Sub
Sub KL(k) '罫線を引く
Sheets(k).Select
LR = Cells(Rows.Count, "B").End(xlUp).Row
Range("B3:K" & LR).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Range("B2").Select
End Sub
今回の処理は、外部から取り込んだ同一様式Bookの集約・集計を行う上で汎用的に使える手法の一つです。
たとえば、支社・支店からの報告書やアンケートの集計にも活用できると思います。
今回も最後までご覧いただき、ありがとうございました。