Excel VBA元データから別シートへ振り分け

元データ（DB)をA列の値で振り分け
別シート（印刷）に転記していく方法について教えてください。
以下のコードで転記は行えましたが１つの値で１つのシートを作成になってしまいます。
どこをどのように変更すればA列の値（一種類に１つのシートにまとめたい）に
１つのシートに転記となるかご教示お願いします。

Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("DB")
Set sh2 = Worksheets("印刷")

d = sh1.Range("A65536").End(xlUp).Row
For i = 2 To d
sh2.Cells(6, "B") = sh1.Cells(i, "A")
sh2.Cells(10, "B") = sh1.Cells(i, "B")
sh2.Cells(10, "C") = sh1.Cells(i, "C")
sh2.Cells(10, "D") = sh1.Cells(i, "D")
sh2.Cells(10, "E") = sh1.Cells(i, "E")
sh2.Cells(10, "F") = sh1.Cells(i, "F")
sh2.Cells(10, "G") = sh1.Cells(i, "G")
sh2.Cells(10, "H") = sh1.Cells(i, "H")
sh2.Cells(10, "J") = sh1.Cells(i, "I")
'sh2.Range("a1:J34").PrintOut
Next i
End Sub

よろしくお願いいたします。

No.5 ベストアンサー 回答者： tom04 回答日時： 2013/11/16 23:00

親の仇のようにお邪魔します。

＞I列→J列にしたいのですが…

そうでしたね！ちゃんと最初の質問にもそうなっていました。
単純にそのままの列にコピー＆ペーストしてしまっていました。

「印刷」SheetのI列には手を加えないようにしています。

Sub Sample4()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents
Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible)
Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible)
myArea1.Copy
wS2.Activate
ActiveSheet.Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues
myArea2.Copy
wS2.Activate
ActiveSheet.Range("J10").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

※　3度目の正直ならぬ、4度目ですが今度はどうでしょうか？

もっと簡単にFor～Nextでループさせた方が間違いなかったかもしれませんが、
敢えて、フィルタにこだわってみました。

今度はどうでしょうか？m(_ _)m

この回答へのお礼

tom04さま
長々とおつきあい頂き本当にありがとうございます。
実際に印刷してまでしてみました。
全てが希望通りです！
感謝いたします！！

また何かありましたらよろしくお願いいたします。

お礼日時：2013/11/16 23:45

No.7 回答者： MarcoRossiItaly 回答日時： 2013/11/17 10:50

No.1・No.6 です。

本来、このサイトの目的は質問・回答ですので、コードの意味を少しだけ解説します。No.5 さんと No.6 の主な内容の比較です。


メインの転記の部分ですが、回答 No.5 では、オートフィルタ（Range.AutoFilter メソッド）により該当レコードのみ抽出し、表示される可視セル（xlCellTypeVisible のセル）をコピー・転記しています。No.6 では、フィルタオプション（Range.AdvancedFilter メソッド）という Excel の異なる機能により、コピーなしで転記しています。

どちらの方法でも転記の前に、「DB」シート A 列のユニークなデータ一覧を得る段階が必要です。No.5 では、こちらのほうをフィルタオプションで行っています。No.6 では、For・If・COUNTIF 関数を併用し、初出でないレコードにおいては処理なしとすることにより、達成しています。

Range.PrintOut メソッドを For ループの内側に入れてあるという点は、両者に共通していますね。

速度的には、No.6 では「約 5 万個のセルの挿入、切り取り、削除を何回か行うという処理」をこちらの判断で加えておいたという要素を除外すれば、どちらの方法でも大差ないかと思います。（ただし、きちんとした検証はしていません）


なお No.6 の文章には一点、コード以外の箇所に記述ミスがありました。すみません。正しくは、次のとおりです。片方は「2」ではなく「1」でした。

×
「下のコードでは、「印刷」シートの I 列に……約 5 万個の…… 2 回ずつ行っています。また、「印刷」シートの A 列に……約 5 万個の…… 2 回ずつ行っています。」
↓
○
「下のコードでは、「印刷」シートの I 列に……約 5 万個の…… 2 回ずつ行っています。また、「印刷」シートの A 列に……約 5 万個の…… 1 回ずつ行っています。」

No.6 回答者： MarcoRossiItaly 回答日時： 2013/11/16 23:01

No.1 です。

＞Aの値が5000種あったとすると5000枚も印刷してしまうのです…。

どうすればいいかについては、No.1 で回答したつもりです。PrintOut メソッドの位置を考えます。プログラムでは、処理の順序というのがたいへん重要です。前後を入れ替えるだけで全く異なる結果になるという事例は、無数にあります。


「DB」シートの A 列のデータが何種類あるのか不明で、順番もバラバラなのだとすると、あまり易しいコードでの達成は難しいと思います。

下のコードでは、「印刷」シートの I 列に何が存在するのか不明なため、約 5 万個のセルを含む範囲の挿入、切り取り、削除を 2 回ずつ行っています。また、「印刷」シートの A 列に何が存在するのか不明なため、約 5 万個のセルを含む範囲の挿入、削除を 2 回ずつ行っています。

やはり PrintOut メソッドの位置に注意してください。「DB」シートの A 列で初出のデータが登場するたびに、「印刷」シートの必要な範囲をクリアし、新たに記入・印刷しています。したがってプロシージャの終了後に「印刷」シートに残っているデータは、「最後の初出」データのみとなります。

なお With ステートメントの導入により、「sh2」の繰り返しの記述を省略するようにしました。


Sub test01()
　　Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, v As Variant
　　Set sh1 = Worksheets("DB")
　　Set sh2 = Worksheets("印刷")
　　Worksheets.Add before:=Worksheets(1)
　　Worksheets(1).Range("a1").Value = "列1"
　　sh1.Rows("2:2").Insert
　　For i = 1 To 9
　　　　sh1.Cells(2, i).Value = "列" & i
　　Next i
　　For i = 3 To sh1.Cells(Rows.Count, "a").End(xlUp).Row
　　　　v = sh1.Cells(i, "a").Value
　　　　If WorksheetFunction.CountIf(Range(sh1.Range("a2"), sh1.Cells(i, "a")), v) = 1 Then
　　　　　　Worksheets(1).Range("a2").Value = v
　　　　　　With sh2
　　　　　　　　.Range("i10:i50000").Insert shift:=xlShiftToRight
　　　　　　　　.Range("k10:k50000").Cut .Range("i10")
　　　　　　　　.Range("k10:k50000").Delete shift:=xlShiftToLeft
　　　　　　　　.Range("b10:i50000").ClearContents
　　　　　　　　.Range("b6").Value = v
　　　　　　　　.Range("b10:b50000").Insert shift:=xlShiftToRight
　　　　　　　　sh1.Range("a2").Resize(sh1.Cells(Rows.Count, "a").End(xlUp).Row - 1, 9).AdvancedFilter _
　　　　　　　　　　Action:=xlFilterCopy, criteriarange:=Worksheets(1).Range("a1:a2"), copytorange:=.Range("b10")
　　　　　　　　.Range("b10:j10").Delete shift:=xlShiftUp
　　　　　　　　.Range("b10:b50000").Delete shift:=xlShiftToLeft
　　　　　　　　.Range("i10:i50000").Insert shift:=xlShiftToRight
　　　　　　　　.Range("k10:k50000").Cut .Range("i10")
　　　　　　　　.Range("k10:k50000").Delete shift:=xlShiftToLeft
　　　　　　　　'.Range("a1:J34").PrintOut
　　　　　　End With
　　　　End If
　　Next i
　　sh1.Rows("2:2").Delete
　　Application.DisplayAlerts = False
　　Worksheets(1).Delete
　　Application.DisplayAlerts = True
End Sub

No.4 回答者： tom04 回答日時： 2013/11/16 21:19

No.2・3です。

たびたびごめんなさい。
No.2の補足の
＞(3)A列の値で多いもので500弱あるので、500行（20ページ）転記できるようにフォーマットを作成しました
を見逃していました。

すでにフォーマットができているというコトですので、コピー＆ペーストは「値」で貼り付ける方が良いと思います。
今までのコードはすべて無視して↓のコードに変更してみてください。

Sub Sample3()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "J")).SpecialCells(xlCellTypeVisible).Copy
wS2.Activate
ActiveSheet.Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Set myArea = Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J"))
myArea.PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

何度も失礼しました。m(_ _)m

この回答への補足

度々お世話になります。
実行してみました。
後ひとつだけお願いします！
DBのI列の値が印刷用のI列に転記されてしまいます。
I列→J列にしたいのですが…
よろしくお願いいたします。

補足日時：2013/11/16 22:15

No.3 回答者： tom04 回答日時： 2013/11/16 20:49

No.2です。

(1)罫線が消えてしまった
(2)フォントサイズが11から9になってしまった
(3)A列の値で多いもので500弱あるので、500行（20ページ）転記できるようにフォーマットを作成しました。
A～J列、１行目から34行目までで1枚です。
なのでたとえ転記された行が１行でも20ページ印刷してしまうのです…
印刷範囲を転記された最終行を含めたページまでとすることは可能でしょうか？

上記の補足の
（1）・（2）に関して
前回のコードは「DB」Sheetにフィルタをかけて、B列最終行までをそのまま「印刷」Sheetにコピー＆ペーストしていますので、
「DB」Sheetの書式がそのままコピーされます。
もしかして、「DB]Sheetのフォントサイズが　9Pt　で罫線もないのでしょうか？

これに関しては「印刷」SheetのB列最終行までのフォントサイズを11Ptに
データがあるまで「格子」罫線にしてみました。

（3）に関して
もしかして、A列または他の列にデータが入っているのでしょうか？
それとも最初から罫線だけがかなり設定してあるのでしょうか？
そうであればデータがあるだけ（空白でも罫線がある行まで）印刷されてしまいますので
「印刷」SheetのB列最終行までを「印刷範囲」としてみました。

もう一度コードを載せてみます。

Sub Sample2()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "J")).Clear '←書式も消してみました
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "J")).SpecialCells(xlCellTypeVisible).Copy wS2.Range("B10")
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
With wS2.Range("B6")
.Font.Size = 11
.Borders.LineStyle = xlContinuous
End With
With Range("B10").CurrentRegion
.Font.Size = 11
.Borders.LineStyle = xlContinuous
End With
Set myArea = Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J"))
myArea.PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

今度はうまくいけばよいのですが・・・m(_ _)m

この回答への補足

tom04さま、早々のご教示ありがとうございます。
DBの書式はおっしゃる通りフォントサイズが9で罫線はありません。
元の書式のせいだったのですね…すみませんでした。
印刷用の方にインデントや赤の太枠など色々と設定しており、
500行分罫線を引きA列にNo.を入力しておりました。

新しいコードで実行したところ、
B6セルに罫線がひかれてしまう、
インデントの設定が消えてしまう、
赤色の太枠が消えてしまう、
表内の罫線（点線）が消えてしまう…などのことがありました。

印刷用のシートの書式設定を崩したくない場合、
DBの書式を印刷用と同じようにして、
最初のコードに「印刷」SheetのB列最終行までを「印刷範囲」というコードを足した方がいいのでしょうか？

Set myArea = Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J"))
myArea.PrintOut
↑最初のコードにこの部分を足すのでしょうか？

度々申し訳ありませんが、もう少しおつきあいください。
よろしくお願いいたします。

補足日時：2013/11/16 21:30

No.2 回答者： tom04 回答日時： 2013/11/16 18:51

こんばんは！

横からお邪魔します。

こういうコトでしょうかね？
尚、Sheet3を作業用のSheetとして使用していますので、Sheet3は使用していない状態でマクロを実行してみてください。

標準モジュールです。

Sub Sample1()
Dim i As Long, endRow1 As Long, endRow2 As Long
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "J")).SpecialCells(xlCellTypeVisible).Copy wS2.Range("B10")
wS2.PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

※　外していたらごめんなさいね。m(_ _)m

この回答への補足

tom04さま、ありがとうございます。
早速実行してみました。
希望通りの転記となりました！素晴らしいです！

後出しで申し訳ありませんが、
困ったことがあります。

(1)罫線が消えてしまった

(2)フォントサイズが11から9になってしまった

(3)A列の値で多いもので500弱あるので、500行（20ページ）転記できるようにフォーマットを作成しました。

A～J列、１行目から34行目までで1枚です。

なのでたとえ転記された行が１行でも20ページ印刷してしまうのです…

印刷範囲を転記された最終行を含めたページまでとすることは可能でしょうか？

$1:$9は印刷タイトルに使用しています。

申し訳ありませんが、よろしくお願いいたします。

補足日時：2013/11/16 19:34

No.1 回答者： MarcoRossiItaly 回答日時： 2013/11/16 16:18

変数 i の宣言は、Long 型としました。

変数 d は、整理しました。他で使う用事があるなど必要な場合は、復活させてください。Range.PrintOut メソッドは、行の位置を入れ替えてあります。


Sub test01()
　　Dim i As Long
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Set sh1 = Worksheets("DB")
　　Set sh2 = Worksheets("印刷")
　　For i = 2 To sh1.Range("A65536").End(xlUp).Row
　　　　sh2.Cells(i + 4, "A").Value = sh1.Cells(i, "A").Value
　　　　Range(sh2.Cells(i + 8, "B"), sh2.Cells(i + 8, "H")).Value = Range(sh1.Cells(i, "B"), sh1.Cells(i, "H")).Value
　　　　sh2.Cells(i + 8, "J").Value = sh1.Cells(i, "I").Value
　　Next i
　　'sh2.Range("a1:J34").PrintOut
End Sub

この回答への補足

MarcoRossiItalyさん、ありがとうございます。
早速やってみたのですが、２点ご報告です。
(1)一枚のシートにDBのA列の値がすべて転記されてしまいます。
(2)DBのA2の値はB6セルに転記させたいのですが、A列すべてに転記されてしまいます。

こちらの説明不足で申し訳ありません。

DBシート
A列　　B列　　C列・・・・I列
200　　201
300　　304
200　　201
300　　302
200　　203

とした時、
印刷シート
B6　200

　　　　B列・・・J列
10行目　201
11行目　201
12行目　203

これで印刷

続いて
印刷シート
B6　300

　　　　B列・・・J列
10行目　304
11行目　302

これで印刷。

この繰り返し。

といったようにDBのA列に出てくる値ごとにまとめて印刷に転記、
印刷→A列の次の値、これをDBの最終行まで行いたいのです。

印刷シートのA列にDBのA列すべての値が転記されてしまっており、
修正の仕方を今いろいろ考えていじってはいるのですが…。

こちらの貼付したコードではDBのA列の値ひとつに対して、
印刷シートにひとつ転記して印刷を開始してしまう。
→Aの値が5000種あったとすると5000枚も印刷してしまうのです…。

申し訳ありませんが、再度ご教示いただけないでしょうか？
よろしくお願いいたします。

補足日時：2013/11/16 17:43