エクセル マクロ

質問

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

回答No.3

kagakusuki

考えられる様々なパターンにおいて、エラー等を回避する様にした処、VBAの構文が非常に長いものになってしまいましたが、以下の様なマクロは如何でしょうか？

Sub QNo8960058_エクセル_マクロ()

Dim myBox As Variant
Dim c, myRange As Range
Dim DefSheet, DefCell, mySheet, myArea(), NotName(9), myNow, myFolder As String
Dim i, n, LastRow As Long
Dim myOK, RewriteON As Boolean
Dim myBook As Workbook

DefSheet = "Sheet1"
DefCell = "A3"
NotName(1) = "\"
NotName(2) = "/"
NotName(3) = "?"
NotName(4) = ":"
NotName(5) = "*"
NotName(6) = """"
NotName(7) = ">"
NotName(8) = "<"
NotName(9) = "|"

label1:
On Error Resume Next
Set myBox = Application.InputBox( _
Prompt:="エリアの名称が入力されている最初のセルをマウス等を使って選択して下さい。" _
, Title:="データが始まっているセルの指定", Default:=DefSheet & "!" & DefCell _
, Type:=8)
If IsError(myBox.Row) Then
myBox = MsgBox("セルが選択されていません" & Chr(13) & "セルの選択をやり直しますか？" _
& Chr(13) & Chr(13) & "[再試行]:セルの選択のやり直し" & Chr(13) & "[キャンセル]:マクロの終了" _
, vbRetryCancel + vbExclamation + DefaultButton2, "無効な選択")
If myBox = vbRetry Then GoTo label1
Exit Sub
End If
On Error GoTo 0
If myBox.Parent.Cells(Rows.Count, myBox.Column).End(xlUp).Row < myBox.Row Then
myBox = MsgBox("選択されたセルから下の範囲にはデータがありません" & Chr(13) & _
"セルの選択をやり直しますか？" & Chr(13) & Chr(13) & _
"[はい]:セルの選択のやり直し" & Chr(13) & "[いいえ]:マクロの終了" _
, vbYesNo + vbExclamation, "データ無し")
If myBox = vbYes Then GoTo label1
Exit Sub
End If

LastRow = myBox.Parent.Cells(Rows.Count, myBox.Column).End(xlUp).Row
Set myRange = myBox _
.Resize(LastRow - myBox.Row + 1, 1)
mySheet = myRange.Parent.Name
Sheets(mySheet).Select
myRange.Select
myBox = MsgBox("この範囲に入力されているエリア名を基準として、" & Chr(13) & _
"データをエリア名ごとに分別したファイルを作成します。" & Chr(13) & Chr(13) & _
mySheet & "!" & myRange.Address(False, False) & Chr(13) & Chr(13) & _
"宜しいですか？" & Chr(13) & Chr(13) & "[OK]:処理を実行します" & Chr(13) & _
"[キャンセル]:処理の実行を中止し、マクロを終了します", vbOKCancel + vbQuestion, "確認")
If myBox = vbCancel Then
MsgBox "マクロを終了します", vbInformation, "処理の中止"
Exit Sub
End If

ReDim Preserve myArea(myRange.Rows.Count - 1)
n = 0
NotName(0) = ""
For Each c In myRange
If Trim(c.Value) <> "" Then
If Application.WorksheetFunction.CountIf(Range(myRange.Resize(1, 1), c), c.Value) = 1 Then
myOK = True
For i = 1 To 9
If InStr(StrConv(c.Value & "", vbNarrow), NotName(i)) > 0 Then myOK = False
Next i
If myOK Then
myArea(n) = c.Value
n = n + 1
Else
NotName(0) = NotName(0) & Chr(13) & mySheet & "!" & c.Address(False, False) _
& " = """ & c.Value & """"
End If
End If
End If
Next c

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)

Set myBook = Workbooks.Add
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

※まだ途中なのですが、このサイトの回答欄の文字数制限である4000文字を超えてしまうため、残りは又後で投稿致します。