Excel・VBAで同じものだけを表示、を繰り返す。

質問

A1　　B1
aaa　涼平
aaa　慶太
aaa　龍一
bbb　右典
bbb　央登
bbb　悠
bbb　恭平
　　：

こんな感じのデータがあります。
これをマクロを実行したら、別シートに
aaa、bbbのまとまりずつ出させプレビューしたいのです。
1回目の表示
a1　　b1
aaa　涼平
aaa　慶太
aaa　龍一

2回目の表示
a1　　b1
bbb　右典
bbb　央登
bbb　悠
bbb　恭平

今現在の状態だと、全部が表示される、ということが回数分（a1の分類がある分だけ）繰り返される、というような感じになってます。

よろしくお願いします。

回答No.4

happypoint

#2です。
＞1回のデータが少なくても、
＞25件分の表示ができるシートを出さなくてはならなくて

では、これならどうでしょう。
データのまとまりごとに、「コピー→値の貼り付け」で処理しています。

注意点としては、
印刷用のシートは「B」という名前と仮定しています。
印刷用のシートにはあらかじめ罫線などの書式設定をすませ、
改ページを２５行ごとに入れておいてください。
「Option Explicit」の行は、すでにある場合は不要です。

Option Explicit
Sub test()

'定数の設定
Const strSheetData As String = "A" 'データ用シート
Const strSheetPreview As String = "B" '印刷用シート
Const lngStartRow As Long = 1 'データ項目の開始行
Const lngStartCol As Long = 1 'データ項目のある列（A列の場合は,1）

'変数
Dim lngMaxRow As Long 'データ最終行
Dim lngRow As Long
Dim i As Long

'項目数を把握
Worksheets(strSheetData).Select
Cells(ActiveSheet.Rows.Count, lngStartCol).Select
Selection.End(xlUp).Select
lngMaxRow = Selection.Row

'Aのデータをなめる
lngRow = 1 '最初の印刷範囲の開始位置
For i = 1 To lngMaxRow
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then '比較して違うデータがでたらここを処理
Sheets(strSheetPreview).Columns("A:B").Clear 'A:B列のデータクリア
Sheets(strSheetData).Range(Cells(lngRow, 1), Cells(i, 2)).Copy 'コピー
Sheets(strSheetPreview).Range("A1").PasteSpecial Paste:=xlPasteValues '値の貼り付け
Sheets(strSheetPreview).PrintPreview 'プレビュー
lngRow = i + 1 '新たな印刷開始位置
End If
Next i

End Sub

回答No.3

imogasi

下記はどうですか。
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
sh1.Range("a1:c100").Sort Key1:=sh1.Range("A1"), Order1:=xlAscending
'------
m = sh1.Cells(1, "A")
j = 1
sh2.Cells(1, "A") = sh1.Cells(1, "A")
sh2.Cells(1, "B") = sh1.Cells(1, "B")
sh2.Cells(1, "C") = sh1.Cells(1, "C")
j = j + 1
For i = 2 To 13
If sh1.Cells(i, "A") = m Then
sh2.Cells(j, "A") = sh1.Cells(i, "A")
sh2.Cells(j, "B") = sh1.Cells(i, "B")
sh2.Cells(j, "C") = sh1.Cells(i, "C")
j = j + 1
Else
sh2.Range(sh2.Cells(1, "a"), sh2.Cells(j - 1, "C")).PrintPreview
sh2.Cells(1, "A") = sh1.Cells(i, "A")
sh2.Cells(1, "B") = sh1.Cells(i, "B")
sh2.Cells(1, "C") = sh1.Cells(i, "C")
j = 2
End If
m = sh1.Cells(i, "A")
Next i
sh2.Range(sh2.Cells(1, "a"), sh2.Cells(j - 1, "C")).PrintPreview
End Sub
Ａ，Ｂ、Ｃ列にデータが入っています。Ａ列がソートキーとします。
ソート後Ａ列で、同じデータが続く限り、そこまでを区切りとして、ＰｒｉｎｔＰｒｅｖｉｅｗ画面を出します。
同じものが５０行を越えた時の対応は要れていませんが
If J>50 Thenとかを入れてそのためにたやすく変えられます。ご参考に。

回答No.2

happypoint

こんなもんでどうでしょう。
定数の設定は、適当に変えてください。

Option Explicit

Sub test()

'定数の設定
Const strSheetData As String = "A" 'データ用シート
Const lngCol As Long = 1 'データ項目のある列（A列の場合は,1）
Const lngStartRow As Long = 1 '最初のデータのある行

'変数
Dim lngMaxRow As Long
Dim lngRow As Long
Dim i As Long

'項目数を把握
Worksheets(strSheetData).Select
Cells(ActiveSheet.Rows.Count, lngCol).Select
Selection.End(xlUp).Select
lngMaxRow = Selection.Row

'Aのデータをなめる
lngRow = 1 '最初の印刷範囲の開始位置
For i = 1 To lngMaxRow
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then '比較して違うデータがでたらここを処理
ActiveSheet.PageSetup.PrintArea = "$A$" & lngRow & ":$A$" & i '印刷範囲のセット
ActiveSheet.PrintPreview
lngRow = i + 1 '新たな印刷開始位置
End If
Next i

End Sub

お礼

回答ありがとうございます。

いただいたお答えだと、
　　　A
1　aaa
2　aaa
3　aaa
4　bbb
5　bbb
　　：
のようになって、印刷1回目がA1：A2の範囲、印刷2回目がA3:A5って感じですよね？
できれば、1回の印刷ごとにシートの中身を変更させるようにしたいのです。
たとえ、1回のデータが少なくても、25件分の表示ができるシートを出さなくてはならなくて。
説明が足りなくてすいませんでした。
（1つのデータが25件以上になった場合は、2ページ・3ページ…となるようにする。）

申し訳ありませんが、これでコードの変更お願いできないでしょうか？
よろしくお願いします。

回答No.1

happypoint

こんにちは。

よかったら現在のコードを提示してください。

お礼

回答ありがとうございます。
現在はこんな感じになってます。
（テスト中ですので、若干おかしなところとかもありますが。。）

よろしくお願いします。

Worksheets("A").Select
Last = Cells(1).CurrentRegion.Rows.Count

a = 33 'とりあえずの全件数
w = 0
For i = 2 To a
Worksheets("A").Select
test1 = Left(Cells(i, 1), 3)
test2 = Left(Cells(i - 1, 1), 3)
If test1 <> test2 Then
w = w + 1
Else
w = w + 0
End If
Next 'Aに入っている件数分

For r = 1 To w
Worksheets("Sheet").Select

For i = 2 To a
Worksheets("A").Select
test1 = Left(Cells(i, 1), 3)
test2 = Left(Cells(i - 1, 1), 3)

Worksheets("Sheet").Select
If Cells(i - 1, 1) = "あああ" Then
Cells(i, 1) = test1
Else
If test1 = test2 Then
Cells(i, 1) = test1
Else
Exit For
End If
End If
Next

ActiveWindow.SelectedSheets.PrintPreview
Next ' w=グループ数が終るまで