エクセル2003の繰り返しマクロ

質問

EXCEL2003のVBAマクロの構文を教えてください。

下記のようにA列に文字が昇順で並んでいるワークブックXXがあります。
Ａ
1あ
2あ
3あ
4い
5い
6う
7え
8お
9お

以下がマクロでやりたいことです。

(1)I行目から、1行目と同じ文字の最下行(この場合は3行目まで)を切り取る
(2)新しいワークブックを作り、開く
(3)それに貼り付ける
(4)それを保存し閉じる
(5)ワークブックXXに戻り、切り取られて空になった行を削除(そしてこの場合4行目が一番上に繰り上がる)

この(1)～(5)までを繰り返し、ワークブックXXが空になったら終了する

回答No.2

imogasi

テストなどやっているうちに、すでに回答が出ましたので、下記は参考までに。
キーの異なるデータ数が２０件ぐらいなら、手作業でやるのが良いが、それ以上だとＶＢＡを使うことになるでしょう。
Ａ列でソート済みらしいので、それを生かして、繰り返し判別回数を少なくしたロジックです。
このように、処理する人によって別のロジックを思いついて、そちらを良しとする場合もあり、同一処理問題にも処理ロジックはいろいろ考えられます。
ーー
ＶＢＡのＣＯＵＮＴＩＦ関数を使って、同じキー（Ａ列データのバラエティの各々）の行数を数えられる。ソート後だと、それらは行的に１塊に、まとまっているのでそれを使っています。
アウトプットは１つのブックの１シートのみを、使いまわしています。
テストデータは、下記Ａ列のデータでやった。
データ
あ
あ
あ
い
い
う
え
お
お
ーー
コードは、標準モジュールに
Sub test01()
Set wba = ThisWorkbook
Set sh1 = wba.Worksheets("Sheet1")
'--
Set wbB = Workbooks.Add
Set sh2 = wbB.Worksheets("Sheet1")
sh2.Range("A1") = "データ"　’見出し文言
k = 1
'--
wba.Activate
lr = sh1.Range("A1000").End(xlUp).Row
MsgBox "最終行数　" & lr
i = 2
'--
While i <= lr
Set wbB = Workbooks.Add
Set sh2 = wbB.Worksheets("Sheet1")
'-- sh2シート アウトプットデータクリア"
sh2.Cells.Clear
sh2.Range("A1") = "データ"
MsgBox "キーデータの塊 " & sh1.Cells(i, "A")
n = WorksheetFunction.CountIf(Range(sh1.Cells(i, "A"), sh1.Cells(lr, "Ａ")), sh1.Cells(i, "A"))
キー項目 = sh1.Cells(i, "A")
MsgBox "続き行数　" & n
wba.Activate
sh1.Select
Range(sh1.Cells(i, "A"), sh1.Cells(i + n - 1, "C")).Copy sh2.Range("A2")
i = i + n
wbB.Activate
'If k = 1 Then
MsgBox "sh2シート アウトプットデータ確認"
'--アウトプット・ブックに書き出し
MsgBox wbB.Name
MsgBox キー項目
Workbooks(wbB.Name).SaveAs Filename:=キー項目 & ".xls"
wbB.Close
k = k + 1
'End If
Wend
End Sub
１歩１歩確認のため、Ｍｓｇｂｏｘを多数入れて、しつこいですが、確信が持てれば、そのコード行を削除するか、コメント化してください。
また途中でおかしいとなったら、この回答は無視してください。質問者は、余りＶＢＡは詳しく無いようなので、訂正修正の深追いは時間のロスになりそうに思う。
当初データでの、Ｂ列以右列のデータのことは、質問には何も触れていませんが、
Range(sh1.Cells(i, "A"), sh1.Cells(i + n - 1, "C")).Copy の”Ｃ”は適当に決めて訂正のこと。
アウトプットのＢ列から以右列の第１行の見出しも、追加コードを入れること。
２００３で遣るらしいが、こちらはテストは２０１３で、やらざるを得なかったので、その点問題ないと思うが特別留意点です。
Ａ列が氏名などの場合、同一人なのに、いろいろ微妙に違う表現になっていたりするので、事前によく考えて、チェックしておくことが必要。
やり直すときは、すでに同じファイル名になりそうなブックがすでにある場合は、てを打っておくこと。
ーー
参考までに、質問の表題の「エクセル2003の繰り返しマクロ 」は内容をうまく表現していないと思う。
「同じ（キーの）データは、まとめて１つのブックに書き出す」などはどうだろう。
表題だけを見て想像し、本文を読むほど暇でない人も多そうだから。

回答No.1

Prome_Lin

必ず、エクセルのファイルを保存してから実行してください。

説明の必要はないかと思いますが、まず、上記の「あああ・・・」の入ったエクセルのファイルを開きます。

最初に、「F12」で「ファイル名を付けて保存」を出し、ファイル名の１行下の右端にある「∨」から「Excel マクロ有効ブック」を選択して保存します。

必ず、保存してください。

「Alt＋F11」（「Alt」（「オルト」と読みます）キーを押しながら、「F11」を押す）と、「Visual Basic」の画面が表示されますので、メニューから「挿入」→「標準モジュール」を選択すると、画面の右側が白くなりますので、その白くなった部分に以下のマクロをコピー＆ペーストし「F5」を押し、実行するのですが、「Test」の方のサブプロシージャを選択してください。

保存した場所に、それぞれのファイル「あ.xlsx」「い.xlsx」・・・が保存されていきます。

Public c As String
Public r As Long
Sub Test()
p = ThisWorkbook.Path
Do Until Range("A1").Value = ""
Call x
Range("A1:A" & r).Copy
Set w = Workbooks.Add()
Set s = w.Worksheets(1)
s.Range("A1").PasteSpecial Paste:=xlPasteValues
w.SaveAs (p & "\" & c & ".xlsx")
w.Close
Set s = Nothing
Set w = Nothing
Rows("1:" & r).Delete
Loop
End Sub

Sub x()
c = Range("A1").Value
For i = 2 To Range("A1").End(xlDown).Row + 1
If Cells(i, 1).Value <> c Then
r = i - 1
Exit For
End If
Next i
End Sub

説明です。

Public c As String
Public r As Long

２つのサブプロシージャで共通の変数を宣言。

Sub Test()

まず、メインのサブプロシージャです。

p = ThisWorkbook.Path

「p」に自分自身（エクセルのマクロ有効ファイル）の存在するフォルダの位置を入れます。

Do Until Range("A1").Value = ""

セル「A1」に値がなくなるまで処理。

Call x

サブプロシージャ「x」を呼び出しています。

Range("A1:A" & r).Copy

サブプロシージャ「x」によって求められた「r」を使って「あ」なら「あ」の範囲をコピー（記憶）しています。

Set w = Workbooks.Add()

新規にワークブックを作成しています。

Set s = w.Worksheets(1)

そのワークブックの一番左端のシートを「s」にセット。

s.Range("A1").PasteSpecial Paste:=xlPasteValues

セル「A1」に、先ほど記憶した値をペースト（貼り付け）ています。

w.SaveAs (p & "\" & c & ".xlsx")

ワークブックを、マクロ有効ブック（マクロを処理している自分自身）と同じフォルダに「あ」なら「あ」という名前で保存しています。

w.Close

閉じています。

Set s = Nothing
Set w = Nothing

オブジェクト解放しています。

Rows("1:" & r).Delete

元に戻って、行を削除しています。

Sub x()

サブプロシージャ「x」です。

c = Range("A1").Value

常に、セル「A1」の値が、最初の値なので、それを「c」に入れています。

For i = 2 To Range("A1").End(xlDown).Row + 1

１行目は分かっているので、２行目から調べ、最後の行＋１行まで調べます。

これは、「c」に入れたセル「A1」の値と違うものが見つかるまで調べないといけないので、最後の「お」だと最終行までしか調べないと、いつまでたっても「お」のままなので、最終行＋１行で、「お」以外を出すためです。

If Cells(i, 1).Value <> c Then

もし、その行のセルの値が、最初のセル「A1」の値と異なれば、

r = i - 1

「その行－１」を、すなわち「あああい」だと、今、「い」の位置なので、「あ」の最後は「i - 1」となるわけです。

Exit For

見つかったので、それ以下を調べる必要がないので、「For Next」ループを抜け出しています。

元のサブプロシージャ「Test」の「Call x」の次の行に戻ります。