エクセル マクロ

質問

A列にエリア、B,C,Dにそのエリアの情報が格納されているエクセルファイルがあります。 エクセルマクロで、A列に入っているエリア（たとえば、東北、関東、関西、四国、九州など）ごとに、そのエリアの行をコピーして新規Bookを作成するというコードを書きたいのですが、どなたかご存知の方ご教授ください。

回答No.8

kagakusuki

>ファイルをエリア分新規作成して、ファイルを一つずつメールの新規メッセージに添付するというのを追加できますでしょうか？エリア毎にメールに添付して送る処理を一気にマクロで処理してしまいたいのですが、このコードに追加でできますでしょうか？

　VBAを使えば大抵の事は出来る筈ですので、おそらく自動的にメールに添付する事を可能にする方法も存在する事とは思います。
　ですが、その様なVBAの構文を組もうとしましても、それが正しく動作するかどうかという動作確認を行うためには、複数のメールアドレスに対して実際にメールを送ってみるしか無い訳で、しかも想定される様々な状況に対してもバグがない事を確認するためにはその様なメールを何度も送らねばならならず、それはメールを送る相手の迷惑にもなりかねませんので、余程親しい間柄の協力者でもいなければ、おいそれと出来る事では無い様な気が致します。
　残念ながら私には(確認のためだけのメールを1通だけならば兎も角、何通も送りつけても失礼にならない程の)親しい間柄の協力者の心当たりが無かったため、マクロによるメールの自動送信を試みようとした事は無く、そのやり方も存じません。

　第一、機械的に処理しただけのファイルなのですから、中身を確認もせずに他者に送るのは如何なものかと思います。
　例えば、元データに入力されていたエリア名の中に、入力ミスによって誤った名称(例えば「関東」と入力しようとして「kntoi」と入力してしまったり、「巻頭」と誤変換してしまったり、「関　東」等の様に途中に空白が挟まれた形式で入力されていたり等)が入力されてしまっている行があったりした場合、正しいエリア名と同じファイル名のファイル(例えば「関東.xlsx」)には、データに欠けが生じる事になります。
　ですから、業務等で行うのであれば、作成されたファイルをメールに添付する前に、一旦内容をダブルチェックする事は必要不可欠ではないかと思われますので、自動送信するのは避けた方が宜しいのではないかと思います。

　尚、「関東」を「kntoi」や「巻頭」、「関　東」等とした場合には、「kntoi.xlsx」、「巻頭.xlsx」、「関　東.xlsx」というファイルが作成されるため、まだ目視によって間違いを発見する事が容易ですが、エリア名を入力し忘れてエリア欄が空欄となっている行や、「関東?」等の様に、何かの拍子に間違ってファイル名には使う事が出来ない文字(「\」、「/」、 「?」、 「:」、「*」、「"」、「>」、「<」、「|」)が含まれたエリア名にしているものがあった場合には、ファイルが作成されないため発見が難しくなります。
　その対策の一案としましては、エリア名毎に別のファイルに振り分ける前に、誤ったエリア名が入力されているものを修正する様にし、その際に役立つ様に、元データのBookに入力されるエリア名として「東北」、「関東」、「関西」、「四国」、「九州」等の様な決まった名称しか使われないのであれば、マクロを起動させる前に、そのエリア名の一覧表を別シート上に作成しておきさえすれば、オートフィルターを使ってその一覧表には存在しないエリア名が入力されている行のみを表示させる様なまた別のマクロを作成する事も可能だと思われますが、如何致しましょうか？

　それから話は変わりますが、エリア名毎のデータを抽出する際や、新たなファイルを作成する際に、その度に表示を切り替えたのでは、液晶モニターの表示を変えるために僅かながら余計な時間が掛かるため、前回の回答で提案させて頂いたマクロの処理速度を少しでも速くするために、処理が終わるまで表示を切り替えない様に改良してみましたので、回答No.6で記述したVBAの構文中の

i = Application.SheetsInNewWorkbook

という行以下の部分を次のものと差し替えて下さい。

i = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Application.ScreenUpdating = False
Set myBook = Workbooks.Add
Application.SheetsInNewWorkbook = i
If myRange.Row > 1 Then
Application.CutCopyMode = False
ThisWorkbook.Sheets(mySheet).Rows("1:" & myRange.Row - 1).Copy
With myBook.Sheets(1).Rows(1)
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
End With
End If
For i = 0 To n
myBook.Sheets(1).Rows(myRange.Row & ":" & LastRow).ClearContents
myRange.AutoFilter Field:=1, Criteria1:=myArea(i)
Application.CutCopyMode = False
ThisWorkbook.Sheets(mySheet).Rows(myRange.Row + Sgn(i) & ":" & LastRow).Copy
With myBook.Sheets(1).Rows(myRange.Row)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
End With
Application.DisplayAlerts = False
myBook.SaveAs Filename:=myFolder & myArea(i) & myNow & ".xlsx"
Application.DisplayAlerts = True
Next i
Application.CutCopyMode = False
myRange.AutoFilter
myBook.Close
Application.ScreenUpdating = True
MsgBox "データをエリアごとに" & n + 1 & "個のファイルに分けて保存しました" _
, vbInformation, "処理の完了"

End Sub