エクセル マクロ

質問

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

回答No.7

kagakusuki · ベストアンサー

回答No.6の続きです。

If NotName(0) <> "" Then
myBox = MsgBox("以下のセルに入力されている値はファイル名として使用出来ない文字が" & _
"含まれているか、或いは空欄であるため、ファイル名として使用出来ません。" & _
Chr(13) & NotName(0) & Chr(13) & Chr(13) & _
"これらのセルが存在している行のデータは無視して、その他の行のデータのみに対して処理を行いますか？" _
& Chr(13) & Chr(13) & "[OK]:ファイル名として使用出来るものに対してのみ処理を行います" & Chr(13) & _
"[キャンセル]:マクロを終了します", vbOKCancel + vbExclamation + vbDefaultButton2, "無効なデータ")
If myBox = vbCancel Then Exit Sub
End If
If n = 0 Then
MsgBox "有効なデータがありません。" & Chr(13) & "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
n = n - 1
ReDim Preserve myArea(n)

label2:
MsgBox "下の[OK]ボタンを押すと現れる" & Chr(13) & "「名前を付けて保存」ダイアログボックスにおいて" _
& Chr(13) & "新規に作成するExcelbookの保存先のフォルダーを選択してから" & Chr(13) & _
"[保存]ボタンを押して下さい。", vbInformation, "操作方法の説明"
label3:
myNow = ""
myFolder = Application.GetSaveAsFilename(InitialFileName:=myArea(0))
If myFolder = "False" Then
myBox = MsgBox("保存先を指定しなければ新しいBookを保存する事が出来ません。" & Chr(13) & _
"保存先を指定し直しますか？" & Chr(13) & Chr(13) & "[再試行]:セルの選択のやり直し" & Chr(13) _
& "[キャンセル]:マクロの終了", vbRetryCancel + vbExclamation, "保存先の再選択")
If myBox = vbRetry Then
GoTo label2
Else
Exit Sub
End If
End If
myFolder = Left(myFolder, InStrRev(myFolder, "\"))
myOK = True
For i = 0 To n
If Dir(myFolder & myArea(i) & ".xlsx") <> "" Then myOK = False
Next i
If Not myOK Then
myBox = MsgBox("指定されたフォルダー内には作成予定のファイルの一部と同名のファイルが既に存在します。" _
& Chr(13) & "既存の同名ファイルに上書きしますか？" & Chr(13) & Chr(13) & _
"[はい]:上書きする" & Chr(13) & "[いいえ]:上書きしない" & Chr(13) & "[キャンセル]:マクロの終了" _
, vbYesNoCancel + vbExclamation + vbDefaultButton2, "重複するファイル名")
Select Case myBox
Case vbYes
Case vbNo
myBox = MsgBox("1つのフォルダー内に同名・同種のファイルを保存する事は出来ませんので、" & _
"保存先を別のフォルダーに変更して下さい。" & Chr(13) & Chr(13) & "[中止]:マクロの終了" & Chr(13) & _
"[再試行]:保存先フォルダー選択のやり直し" & Chr(13) & "[無視]:年月日時分秒付きのファイル名で保存" _
, vbAbortRetryIgnore + vbExclamation + vbDefaultButton2, "重複するファイル名")
Select Case myBox
Case vbAbort
Exit Sub
Case vbIgnore
myNow = Now
Case Else
GoTo label3
End Select
Case vbCancel
Exit Sub
Case Else
GoTo label3
End Select
If myNow <> "" Then
Do Until Dir(myFolder & "*" & Format(myNow, "_yyyymmdd_hhmmss") & ".xlsx") = ""
myNow = DateAdd("s", 1, myNow)
Loop
myNow = Format(myNow, "_yyyymmdd_hhmmss")
End If
End If

i = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
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

End Sub

　以上です。

お礼

色々どうもありがとうございます。
私には高度すぎでわかりませんでしたが、検証してみます。
本当にどうもありがとうございました。

補足

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