2019/12/10

１行１データの表を複数行１データとして印刷する

０．はじめに

Excelのワークシートは何にでも使えます。書類の帳票として見栄えが良いように、１つのセルの中に改行を入れて複数行を記入したり、隣のセルと結合（Mergeと言います）したりします。またデータの表であっても、下図のように複数行で１列のデータだったり、カラの列があったりと、見やすく、印刷時の収まりが良いように各人が工夫を凝らしています。

ですが、このように並んでいるデータを「並び変え」たり、「フィルター」を掛けたりすることは出来るでしょうか。まず標準のオートフィルターでは不可能でしょう。
難しいマクロを作りたくて仕方がない人ならワクワクするでしょうが、これは無駄であり罪です。

Excelのデータは「単純に１行１データで、１セルに１単位のデータを入れる」のが一番です。「正規化」という言葉を知っている人がいるなら「趣味の項目は複数存在するから、別テーブルにすべき」というかもしれませんが。SQLでデータを処理するのでなければ、そこまでは必要ないでしょう。

１．「１行１データ」の表を「必要な項目を複数行１データ」に変換する

では、「単純に１行１データで、１セルに１単位のデータを入れる」を実施したとしましょう。しかし、データが横に長くなり印刷してもA3横でも文字が小さすぎ、不必要な列を非表示にしたり・・・と苦労した経験を持つ人もいるでしょう。
そこで以下のような例を考えてみます。左図は元のデータで、右図が印刷時だけに作成する複数行１データの表です。「印刷」ボタンを押すと、左のデータが右のフォーマットに並びなおし、罫線も揃えてから印刷。印刷が終わったら、プリント用のデータと罫線は消して終了、というイメージです。

1-1．データ表とプリント表のタイトルを記憶する

以下のマクロをVBEに記述します（シート、ブック、標準モジュール　のどこでも動作しますが、複数のシートを対象に動作させますので、ブックか標準モジュールが良いと思います）。
  1. Dim Data_Sh , Print_Sh As Worksheet　　　 '←データ用シートとプリント用シートの変数を宣言
  2. Dim Title_Array()　　　　　　　　　　　　 '←タイトル位置の対比表を動的配列として宣言
  4. Sub Sh_Print()　　　　　　　　　　　 '←「印刷ボタン」等から呼び出されるメインプロシージャ
  5. 　Set Data_Sh = Sheets("sheet1")　　　 '←データ用シートとして"sheet1"を代入
  6. 　Set Print_Sh = Sheets("sheet2")　　　 '←プリント用シートとして"sheet2"を代入
  7. 　Call Data_t
  8. 　Call Print_t
  9. End Sub
  11. Sub Data_t()　　　　　　　　　　　　 '←データ用シートのタイトルを記憶
  12. 　Dim Last_Col As Range
  13. 　Dim i As Integer
  14. 　Set Last_Col =Data_Sh.Cells(1, Columns.Count).End(xlToLeft) 　　 '←タイトル行の右端セル
  15. 　ReDim Title_Array(1 To 3, 1 To Last_Col.Column) 　　　　　　　　 '←タイトル項目数に合わせて配列を再構築
  16. 　i = 1
  17. 　For Each Data_Title In Range(Data_Sh.Cells(1, 1), Last_Col)　　　 '←タイトル行を１つずつ取り出す
  18. 　　Title_Array(1, i) = Data_Title.Value 　　　　 '←タイトル文字列を配列に代入
  19. 　　i = i + 1
  20. 　Next Data_Title
  21. End Sub
  23. Sub Print_t()　　　　　　　 '←プリント用シートのタイトルを記憶
  24. 　Dim j As Integer
  25. 　For Each Print_Title In Print_Sh.UsedRange 　　　　 '←タイトル部分を１つずつ取り出す
  26. 　　For i = 1 To UBound(Title_Array, 2) 　　　　 '←タイトル項目数分を繰り返す
  27. 　　　If Title_Array(1, i) = Print_Title.Value Then 　　　 '←データ用タイトルとプリント用タイトルが合えば実施
  28. 　　　　Title_Array(2, i) = Print_Title.Row 　　　 '←プリント用タイトルの行位置を配列の2要素目に代入
  29. 　　　　Title_Array(3, i) = Print_Title.Column 　　　　 '←プリント用タイトルの列位置を配列の3要素目に代入
  30. 　　　End If
  31. 　　Next i
  32. 　Next Print_Title
  33. End Sub

このマクロでメインのSh_Printプロシージャを実行させても、タイトルの情報を配列に格納するだけなので表面上は何も起こりません。何が起こっているかを、ウォッチウィンドウで確認しましょう。
今回は、メインプロシージャ「Sub Sh_Print()」の最後である「End Sub」の部分にブレークポイント（その行の左端列をクリックするか、その行にカーソルを当ててファンクションキーの「F9」を押すかして茶色の丸印をつける）を設定した後、メインプロシージャを実行させます。
すると、「End Sub」の行が黄色になります。これはこの黄色のコードの直前でプログラムが一時停止したことを表しています。この状態で、配列変数である「Title_Array」をマウスで選択しマウス右クリックから「ウォッチ式の追加」すると、ウォッチウィンドウに「Title_Array」が追加されます。
ウォッチウィンドウの「Title_Array」には先頭にプラス印がついていますので、クリックすることで下図のように配列内容が確認できます。


このウォッチウインドウの「Title_Array」配列データを表にしてみると、以下のようになります。
　　　　1　　2　　3　　4　　5　　6　　7　　8　　9　
(1)ABCDEFGHI
(2)222233333
(3)234623467

元となったワークシートのタイトル部も並べてみましょう。上がデータ用シート、下がプリント用シートのタイトルです。




配列「Title_Array」は、プログラムの15行目でTitle_Array(1～3,1～9)のサイズにしてあります。今回、データ用シートはＡ列（１列目）から始まっているのを前提としていますので、配列の列番号とデータ用シートの列番号があっており、１行目にデータ用シートの項目名を代入してあります。（ここまでが、「Sub Data_t」プロシージャ部分）
そして「Sub Print_t」プロシージャでは、プリント用シートの各項目名を配列の1行目の項目名と比較し、２行名にその行位置、３行目に列位置を代入します。

もし同じ項目名が無い場合には２行目、３行目はカラになりますし、同じ項目がダブりで存在した場合には最後に合致した位置が最終的に記録されます。もし、最初に合致した位置を記録したい場合は、If～EndIf内の29行目の下に「Exit For」を追加してFor～Nextを抜けて下さい。
また、セルが結合（Merge）されている場合は、一番左上のセルの位置が記録されます。

1-2．データのあるセル範囲の取得方法

ここで、タイトル部分の範囲を取得する方法が２つ出てきました。

１つ目は、14行目で出てきた「Data_Sh.Cells(1, Columns.Count).End(xlToLeft)」です。
「Data_Sh.Cells(1, Columns.Count)」が基準となるセル位置で、この中の「Columns.Count」はApplicationオブジェクト（＝Excel）のColumnsプロパティで、Excelでの最大列数を表します。つまり「Cells(1, Columns.Count)」はワークシート全体の一番右上のセルを指しています。
その後ろの「.End(xlToLeft)」プロパティは、キー操作で言えば「End」キーを押した後、「←」左矢印キーを押すのと同等です。この操作をすれば、飛んで何か文字の入っているセルを選択しますので、タイトル行の一番右側が取得できることになります。
タイトル項目が左端から連続して記入されている場合であれば「Data_Sh.Cells(1, 1).End(xlToRight)」でも同じ結果が得られますが、途中に空欄がある可能性がある場合には、右端から特定することで本当の最終セルを得られます。
上下方向も「xlUp」「xlDown」で範囲を特定することができます。
但しこの方法で複数行のタイトルの右端を取得するには、１行ずつ下にずらしながら探索していかねばならない、どこがタイトル行の最終行か分からない、という弱点があります。

２つ目は、25行目で出てきた「Print_Sh.UsedRange」です。
UsedRangeとは、Worksheetオブジェクトに対して使われたセル範囲を使われていない行と列で挟まれた方形で返します。「使われたセル」というのはセルに（文字列とか数値とかの）値が入っているだけではなく、スペースが入っているのは当然として、セルに色が付いたり、罫線が引かれていたり、セル高さが変更されたり、というのも含まれます。
ですので、今回の例のプリント用シートの様にタイトル行の下に罫線が引かれている場合は、その全てが「使われたセル」と判断されます。それでも上記のマクロではタイトル項目が合致しないため、罫線だけのセルは無視されます。

別な方法として「CurrentRegion」があります。
これは、Rangeオブジェクトに対するプロパティで、「特定のセル位置を含む空白の行と空白の列ので囲まれた範囲」を返します。ですので、今回のプリント用シートで「Print_Sh.Cells(2,2).CurrentRegion」とすると、E列が空行のために「D,H,I」の項目セルは対象外となってしまいます。データの中に空白部分が存在する場合には使いにくいプロパティです。
尚、このCurrentRegionは、セル中に値があるか否かだけが対象で、セル色や罫線はあっても無くても関係ありません。

また「SpecialCells()」を使う方法もあります。
これは、Range オブジェクトに対するメッソドで、特定の条件に該当するセルをまとめて取得するもので、引数としては以下のものがあります。
　引数　()内は定数として値が一緒のもの　値意味
xlCellTypeAllFormatConditions　-4172　表示形式が設定されているセル
xlCellTypeAllValidation　-4174　条件の設定が含まれているセル
xlCellTypeBlanks　　4　空白セル
xlCellTypeComments　-4144　コメントが含まれているセル
xlCellTypeConstants（xlConstants）　　2　定数が含まれているセル（第二引数として定数を設定可能）
xlCellTypeFormulas　-4123　数式が含まれているセル（第二引数として数式を設定可能）
xlCellTypeLastCell（xlLastCell）　　11　使われたセル範囲内の最後のセル
xlCellTypeSameFormatConditions　-4173　同じ表示形式が設定されているセル
xlCellTypeSameValidation　-4175　同じ条件の設定が含まれているセル
xlCellTypeVisible（xlVisible）　　12　すべての可視セル
今回の場面で使うとすれば２つの引数が使えそうです。

１つ目は「xlCellTypeLastCell（xlLastCell）」で、使われたセルの範囲の内で最後（一番右下）のセルを返します。
  1. For Each Print_Title In Range(Print_Sh.Cells(2, 2), Print_Sh.Cells(2, 2).SpecialCells(xlLastCell))
Rangeオブジェクトのメソッドなので基準セルは省略は出来ませんが、「cells(1,1)」でも「cells(100,100)」でも、そのシート内で使われた最後のセルが返ります。なお「UsedRange」と同様でセル色、罫線、セル高さなどを変更したセルも含まれてしまいます。

もう一つは「xlCellTypeConstants（xlConstants）」を使うことで、タイトル文字の入った範囲を取得できます。
  1. For Each Print_Title In Print_Sh.Cells(3, 2).SpecialCells(xlConstants)
上の引数と同様に、「cells(1,1)」でも「cells(100,100)」でも、そのシート内で値（文字・数字が対象。数式は除かれます）の入っているセルが返ります。また、間に空白行・空白列があっても関係なく、飛び地のようにセル範囲を取得できます。ですので。For Each～Nextで調べていくのには効率的かもしれません。

1-3．データをプリント用シートに貼りこむ

では、配列「Title_Array」を通して、データ用シートからプリント用シートにデータをコピーしていきます。
まず、データ用シートに何行のデータがあるかを調べますが、データの中に「カラのセルがある」「カラの行がある」「キー項目（データが必ず入っている列）が無い」などのデータ欠落がある場合があります。 「1-2．データのあるセル範囲の取得方法」で全部で５つの方法を示しましたが、どんなデータかで使う方法を選ぶ必要があります。
手法End(xlUp)UsedRangeCurrentRegionSpecialcells
(xlLastCell)		Specialcells
(xlConstants)
ﾃﾞｰﾀが詰まっている○○○○○
空のセルがある×○○○○
空の行がある○○×○○
キー項目が無い×○○○○
返り値単一セルセル範囲セル範囲単一セルセル範囲
表を少し補足しますと、「End(XlUp)」は下の方からセルが上がってくるイメージですが、カラのセルの場所を検索するとズレが生じます。しかしキー項目（データが必ず入っている列）が分かっていれば、その列で検索すれば正しいデータ行数が得られます。
また、得たい範囲は「データの範囲」です。データの始まりは分かっているので、「単一セル」としてデータの最下端が得られれば簡単に範囲特定できますが、返り値が「セル範囲」の場合は項目名を含んでいますので、それを取り除く処理（IF文を使用するか、範囲の一番終わりを取得した後にデータ初めと合わせてデータの範囲とする　等）が必要になってきます。

ここではUsedRangeを使って２通りのやり方にトライしてみます。まずはIF文を使った方法が下記になります。
尚、メインプロシージャである「Sub Sh_Print()」にはデータコピーのプロシージャ「Data_Copy」の呼び出しを追加して下さい。
  1. Sub Data_Copy()
  2. 　Dim P_row_array as Variant　　　　　　　 '←プリント用シートのタイトル行位置を入れる配列
  3. 　Dim P_count,P_row,P_col as Integer
  4. 　With WorksheetFunction
  5. 　　P_row_array=.Index(Title_Array, 2, 0) 　　　 '←配列Title_Arrayから2行目だけを取り出す
  6. 　　P_count=.Max(P_row_array)- .Min(P_row_array)+1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  7. 　End　With
  9. 　For Each Dat In Data_Sh.UsedRange　　　 '←ﾃﾞｰﾀ用ｼｰﾄの使われたｾﾙ(ﾀｲﾄﾙ行含)を1つずつ調べる
  10. 　　If Dat.row=1 then GoTo CONTINUE　　　 '←ｾﾙの行位置が1(=ﾀｲﾄﾙ行)なら飛ばして次のｾﾙへ
  11. 　　If Title_Array(2, Dat.Column) <> "" Then　　　 '←ｾﾙの行位置がカラで無かったら
  12. 　　　P_row=Title_Array(2, Dat.Column) 　　　 '←配列の2行目の値(行位置)
  13. 　　　P_col=Title_Array(3, Dat.Column) 　　　 '←配列の3行目の値(列位置)
  14. 　　　Print_Sh.Cells(P_row, P_col).Offset((Dat.Row - 1) * P_count, 0) = Dat.Value　　　 '←行数分ずらしたｾﾙに値を貼る
  15. 　　End If
  16. 　CONTINUE:　　　 '←調べるセルがタイトル行だった時にはここへ飛ぶ
  17. 　Next Dat
  18. End Sub
メインプロシージャへ「データコピーのプロシージャ」呼び出しを追加。
  1. Sub Sh_Print()　　　　　　　　　　　 '←メインプロシージャ
  2. 　Set Data_Sh = Sheets("sheet1")
  3. 　Set Print_Sh = Sheets("sheet2")
  4. 　Call Data_t
  5. 　Call Print_t
  6. 　Call Data_Copy　　　　　　 '←データコピーのプロシージャ呼び出しを追加
  7. End Sub

先頭でWorksheetFunctionを使ってなにやらやっている部分から説明します。この部分はデータコピーの本体では無いのですが、その本体でどうしても使用しなければならない「プリント用シートのタイトル部分は何行あるのか」を計算している部分であるのと同時に、「配列の中のデータをうまく活用する」という意味でも説明したいと思います。

このマクロを作っているあなたが「プリント用タイトルが何行あるか」を調べようとしたら、どうするでしょうか。
１つは、プリント用タイトルを調べているプロシージャ「Sub Print-t()」の中で。UsedRangeでタイトルセルの範囲を取得している為、その時一緒に行数を取る方法があります。UsedRangeは罫線だけのセルも範囲に含めてしまいますので、セルに値が入っているかの確認だったり、他の範囲取得の手段を使うとかの工夫は必要かと思います。
２つ目は、配列Title_Arrayの２行目の各値をFor～Next等で取得しながら比較し、最大行・最小行を計算させる方法もあります。
３つ目として、その配列をもう少し効率良く使って、タイトル行数を取得してみます。

繰り返しになりますが、配列Title_Arrayは以下のようなマトリックスになっています。１行目はタイトルの項目、２行目はプリント用タイトルの行位置、３行目は列位置です。
　　　　1　　2　　3　　4　　5　　6　　7　　8　　9　
(1)ABCDEFGHI
(2)222233333
(3)234623467

ワークシート関数の中に、「INDEX（配列 . 行番号 . 列番号）」というのがあります。上の様な配列を使って、
「=INDEX（Title_Array , 3 , 4）」とすれば「６」という値が返ってくるはずです。
では、列番号に「０（ゼロ）」を入れるとどうなるでしょう。実は「行全体の値が配列として返される」のです。つまり、「Index(Title_Array, 2, 0)　」は、以下の配列を返します。
　　　　1　　2　　3　　4　　5　　6　　7　　8　　9　
(2)222233333
２行目の値ですからプリント用タイトルの行位置ですよね。これの最大と最小の差がタイトルの行数なので、今度はワークシート関数のMax、Min を使います。ワークシート関数Maxの書式は「Max（数値1 , 数値2 , 数値3 , ・・・）」のはずでしたよね。でも、数値をカンマで区切って並べなくても、こんな風に配列をドンッと渡してしまえば、その中のMax値を返してくれます。

また、今回は２行目のデータだけを使ってMax、Minを計算していますが。例えば「２行目と３行目の中での最大値は？」みたいな計算をする必要があった時には、先ほどの方法で２行目と３行目を取り出したのち、Arrayで一つの配列にくっつけてからMax計算をすれば良いのです。以下のマクロは、このままでは動きませんが、同じサイズの配列を結合すればMax関数等を使って計算が出来ます。
  1. With WorksheetFunction
  2. 　P_row_array2 = .Index(Title_Array, 2, 0) 　　 '←２行目を抽出する
  3. 　P_row_array3 = .Index(Title_Array, 3, 0) 　　 '←３行目を抽出する
  4. 　P_row_array23 = Array(P_row_array2, P_row_array3) 　　　 '←２行目と３行目を結合する
  5. 　Array_Max = .Max(P_row_array23) 　　　　　 '←２行目と３行目の中で最も大きな値を取得する
  6. End With


次コピペの本体であるFor Each～In の中を説明します。
まず10行目のIF文ですが、UsedRangeで取得した範囲はタイトル行を含むものですので「もし調べるセルの行位置が1（＝タイトル行）だったら無視する」という処理をし、次の調べるセルに飛ぶ直前であるNext Datの直前へGoToで飛んでいます。
もちろん、GoToでは無くIf文を全体に掛けてしまう方法も有りです。このくらい短いコードであれば問題なく使えると思いますが、長いコードの場合はIFに対するEnd If がどこなのか分からなくなる場合がありますのでGOTOで飛ばした方が見易くなると思われます。
次に11行目ですが、データ用シートにはあってプリント用シートには無いタイトルがある（＝プリント用シートにはコピーしない項目がある）場合があります。その場合は「プリント用シートのタイトルを記憶」するPrint_tプロシージャの中で、データ用タイトルとプリント用タイトルが合致しない事になるため、行位置・列位置が入りません。つまり行位置（列位置を使っても同じです）がカラの時にはデータのコピーをしない事になります。

タイトル位置配列Title_Arrayの中に行位置データがある場合は、プリント用シートの所定の行・列の位置にデータ用シートの値を貼りつけます。しかし、Title_Array配列の中に入っている行・列の位置は、プリント用シートの「タイトルの位置」であって、データの位置ではありません。データはタイトルの下に並ぶようにズラす必要があります。
では「どれだけズラすべきか」ですが、例えばデータ用シートの１行目のデータは、対応するプリント用シートの「タイトル位置のタイトル行分（今回の場合は２行分）下に書け」ば良いと分かります。次に、データ用シートの２行目のデータは、対応するプリント用シートの「タイトル位置のタイトル行分（今回の場合は２行分）下」の「タイトル位置のタイトル行分（今回の場合は２行分）下」に書けば良いのです。これをまとめてみると、

ﾌﾟﾘﾝﾄ用ﾃﾞｰﾀの位置 ＝「ﾌﾟﾘﾝﾄ用ﾀｲﾄﾙ行の位置」 から下に 「ﾌﾟﾘﾝﾄ用ﾀｲﾄﾙ行数 ｘ （ﾃﾞｰﾀ用ｼｰﾄのﾃﾞｰﾀの行位置 － １）」分ずらす

となります。これをVBAの式にしたのが14行目の「Print_Sh.Cells(P_row, P_col).Offset((Dat.Row - 1) * P_count, 0) = Dat.Value」になります。
もし分かりにくいようであれば、これはどうでしょう。

ﾌﾟﾘﾝﾄ用ﾃﾞｰﾀの位置 ＝「ﾌﾟﾘﾝﾄ用ﾀｲﾄﾙ行の位置」 から下に 「ﾌﾟﾘﾝﾄ用ﾀｲﾄﾙ行数 ｘ ﾃﾞｰﾀ用ｼｰﾄのﾃﾞｰﾀの順番」分ずらす

これをVBAにすると、以下のようになります。
  1. Sub Data_Copy()
  2. 　Dim P_row_array as Variant 　　　　　　　 '←プリント用シートのタイトル行位置を入れる配列
  3. 　Dim P_count,P_row,P_col,D_count as Integer
  4. 　With WorksheetFunction
  5. 　　P_row_array=.Index(Title_Array, 2, 0) 　　　 '←配列Title_Arrayから2行目だけを取り出す
  6. 　　P_count=.Max(P_row_array) - .Min(P_row_array)+1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  7. 　End　With
  9. 　For Each Dat In Data_Sh.UsedRange 　　　 '←ﾃﾞｰﾀ用ｼｰﾄの使われたｾﾙ(ﾀｲﾄﾙ行含)を1つずつ調べる
  10. 　　D_count=Dat.Row - 1 　　　　　　 '←ﾃﾞｰﾀが何番目か計算する
  11. 　　If Dat.row=1 then GoTo CONTINUE 　　　 '←ｾﾙの行位置が1(=ﾀｲﾄﾙ行)なら飛ばして次のｾﾙへ
  12. 　　If Title_Array(2, Dat.Column) <> "" Then　　　 '←ｾﾙの行位置がカラで無かったら
  13. 　　　P_row=Title_Array(2, Dat.Column) 　　　 '←配列の2行目の値(行位置)
  14. 　　　P_col=Title_Array(3, Dat.Column) 　　　 '←配列の3行目の値(列位置)
  15. 　　　Print_Sh.Cells(P_row, P_col).Offset(D_count * P_count, 0) = Dat.Value 　　　 '←行数分ずらしたｾﾙに値を貼る
  16. 　　End If
  17. 　CONTINUE:　　　 '←調べるセルがタイトル行だった時にはここへ飛ぶ
  18. 　Next Dat
  19. End Sub

データを調べるための順番は、今回は For Each～Inで行っていますので、何番目のデータなのかはデータの行数を調べるしかありません。もしFor～Nextを使ってデータ用シートのデータを上の方から順番にもってくるのであれば、以下のような流れになります。For～Nextを二重にして行と列を回していく方法です。
  1. Sub Data_Copy()
  2. 　Dim P_row_array as Variant 　　　　 '←プリント用シートのタイトル行位置を入れる配列
  3. 　Dim P_count,P_row,P_col,D_row,D_col as Integer
  4. 　With WorksheetFunction
  5. 　　P_row_array=.Index(Title_Array, 2, 0) 　　　 '←配列Title_Arrayから2行目だけを取り出す
  6. 　　P_count=.Max(P_row_array) - .Min(P_row_array)+1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  7. 　End　With
  9. 　For D_row=1 to Data_Sh.UsedRange.Rows.Count -1 　　　 '←ﾃﾞｰﾀ用ｼｰﾄのﾃﾞｰﾀ行を1行ずつ調べる
  10. 　　For D_col=1 to Ubound(Title_Array,2) 　　　　 '←ﾃﾞｰﾀ用ｼｰﾄのﾃﾞｰﾀ列を1つずつ調べる
  11. 　　　If Title_Array(2, D_col) <> "" Then 　　　 '←ｾﾙの行位置がカラで無かったら
  12. 　　　　P_row=Title_Array(2, D_col) 　　　 '←配列の2行目の値(行位置)
  13. 　　　　P_col=Title_Array(3, D_col) 　　　 '←配列の3行目の値(列位置)
  14. 　　　　Print_Sh.Cells(P_row, P_col).Offset(D_row* P_count, 0) = Data_Sh.Cells(D_row+1,D_col).Value
  15. 　　　End If
  16. 　　Next D_col
  17. 　Next D_row
  18. End Sub

また、事前に行数を調べず「カラの行が来るまでDo～Loopで回す」という方法もあります。
私としては永久ループになるのが怖いので必要最小限でしか使いませんし、今回の場合みたいにデータ量が先に分かる事でその後の処理の判断が出来ることにも意味があるでしょうから、出来ればこれ以外をお勧めします。
  1. Sub Data_Copy()
  2. 　Dim P_row_array as Variant 　　　 '←プリント用シートのタイトル行位置を入れる配列
  3. 　Dim P_count,P_row,P_col,D_row,D_col,Null_count as Integer
  4. 　With WorksheetFunction
  5. 　　P_row_array=.Index(Title_Array, 2, 0) 　　　 ←配列Title_Arrayから2行目だけを取り出す
  6. 　　P_count=.Max(P_row_array) - .Min(P_row_array)+1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  7. 　End　With
  9. 　D_row=1
  10. 　Do
  11. 　Null_count = 0　　　 '←カラの行か否かを計算する初期値
  12. 　　For D_col=1 to Ubound(Title_Array,2) 　　　　 '←ﾃﾞｰﾀ用ｼｰﾄのﾃﾞｰﾀ列を1つずつ調べる
  13. 　　　If Data_Sh.Cells(D_row + 1, D_col).Value <> "" Then Null_count = Null_count + 1
  14. 　　　If Title_Array(2, D_col) <> "" Then 　　　 '←ｾﾙの行位置がカラで無かったら
  15. 　　　　P_row=Title_Array(2, D_col) 　　　 '←配列の2行目の値(行位置)
  16. 　　　　P_col=Title_Array(3, D_col) 　　　 '←配列の3行目の値(列位置)
  17. 　　　　Print_Sh.Cells(P_row, P_col).Offset(D_row* P_count, 0) = Data_Sh.Cells(D_row+1,D_col).Value
  18. 　　　End If
  19. 　　Next D_col
  20. 　　D_row = D_row + 1
  21. 　Loop Until Null_count = 0
  22. End Sub

どの方法でも良いですが、「コードが読み易い」「流れが分かり易い」「どんなデータが来てもエラーになりにくい」方法を選んで下さい。

1-4．データを貼りこむ時間を短縮する

今まで説明したのは、「１つのデータを調べて１つのデータを貼る」というのをデータが無くなるまで繰り返す、という方法でした。少ないデータでしたらその実行時間は気にならないのですが、「セルに値を貼り付ける」という行為はコンピュータにとっては非常に時間がかかる行為なのです。

1-4-1．ScreenUpdating の使用
その短縮方法の１つ目ですが、セルに値を貼り付けた後「画面を更新する」のに時間がかかっているので、「画面の更新を停止させる」という方法です。
  1. Sub Data_Copy()
  2. 　Application.ScreenUpdating = False
  3. 　　Dim P_row_array as Variant 　　　 '←プリント用シートのタイトル行位置を入れる配列
  4. 　　Dim P_count,P_row,P_col as Integer
  5. 　　With WorksheetFunction
  6. 　　　P_row_array=.Index(Title_Array, 2, 0) 　　　 '←配列Title_Arrayから2行目だけを取り出す
  7. 　　　P_count=.Max(P_row_array) - .Min(P_row_array)+1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  8. 　　End　With
  10. 　　For Each Dat In Data_Sh.UsedRange 　　　 '←ﾃﾞｰﾀ用ｼｰﾄの使われたｾﾙ(ﾀｲﾄﾙ行含)を1つずつ調べる
  11. 　　　If Dat.row=1 then GoTo CONTINUE 　　　 '←ｾﾙの行位置が1(=ﾀｲﾄﾙ行)なら飛ばして次のｾﾙへ
  12. 　　　If Title_Array(2, Dat.Column) <> "" Then　　　 '←ｾﾙの行位置がカラで無かったら
  13. 　　　　P_row=Title_Array(2, Dat.Column) 　　　 '←配列の2行目の値(行位置)
  14. 　　　　P_col=Title_Array(3, Dat.Column) 　　　 '←配列の3行目の値(列位置)
  15. 　　　　Print_Sh.Cells(P_row, P_col).Offset((Dat.Row - 1) * P_count, 0) = Dat.Value 　 '←行数分ずらしたｾﾙに値を貼る
  16. 　　　End If
  17. 　　CONTINUE:　　　 '←調べるセルがタイトル行だった時にはここへ飛ぶ
  18. 　　Next Dat
  19. 　Application.ScreenUpdating = True
  20. End Sub

セルの書き換えを行っているプロシージャ（今回はData_Copyプロシージャ）の先頭で「Application.ScreenUpdating」を停止（=False）、最後で開始（=True）を設定します。これにより、データを全て貼り付けたのち、画面更新されますので、一瞬でデータが張り付いた様に見えます。
なお、マクロが全て完了すると自動的に画面更新が開始されますので、「Application.ScreenUpdating=True」を記入しなくてもデータは見えるようにはなるのですが、「あなたの思った通りにプログラムを動かす」ためにも必ず「自分で停止させたら、自分で開始させる」を行ってください。

また同様に「Application.EnableEvents= False」を先頭に記入することで、イベントが発生しなくなり実行時間が短縮します。ただし、この設定は、ScreenUpdatingと違ってマクロ完了しても自動的にはイベント開始とはなりません。必ず開始（=True）させる事は当然として、慎重に使用しないと痛い目に会いますので、慣れてから使うようにして下さい。

1-4-2．配列にして一気に貼り付ける方法
短縮方法の２つ目ですが、「セルに値を貼り付ける」という行為を１回で終わらせる、という方法です。１つずつセルに値を貼る代わりに、プリント用シートのイメージした新しい配列に値を入れ、最後に一気に貼り付けるというものです。とりあえずプログラムを見て下さい。
  1. Sub Data_Copy()
  2. 　Dim P_array() As Variant 　　　　 '←プリント用シートに貼り付けるデータを格納する配列
  3. 　Dim P_row_array , P_col_array as Variant 　　 '←プリント用シートのタイトル行位置・列位置を入れる配列
  4. 　Dim P_row_Max,P_col_Min as Integer 　　　　 '←プリント用シートのタイトルの最下端行、最左端列
  5. 　Dim P_row,P_col as Integer 　　　　 '←貼り付け配列の中の行と列
  6. 　Dim P_start_cell As Range 　　　　 '←貼り付ける左上のセル位置
  8. 　With WorksheetFunction
  9. 　　P_row_array = .Index(Title_Array, 2, 0) 　　 '←配列Title_Arrayから2行目（行位置）を取り出す
  10. 　　P_row_count = .Max(P_row_array) - .Min(P_row_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  11. 　　P_row_Max = .Max(P_row_array) 　　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最下端行を計算
  12. 　　P_col_array = .Index(Title_Array, 3, 0) 　　 '←配列Title_Arrayから3行目（列位置）を取り出す
  13. 　　P_col_count = .Max(P_col_array) - .Min(P_col_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ列数を計算
  14. 　　P_col_Min = .Min(P_col_array) 　　　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最左端列を計算
  15. 　End　With
  17. 　Set P_start_cell = Print_Sh.Cells(P_row_Max + 1, P_col_Min)
  18. 　ReDim P_array(1 To (Data_Sh.UsedRange.Rows.Count - 1) * P_row_count , 1 To P_col_count) 　 '←配列ｻｲｽﾞを決定
  20. 　For Each Dat In Data_Sh.UsedRange 　　　 '←ﾃﾞｰﾀ用ｼｰﾄの使われたｾﾙ(ﾀｲﾄﾙ行含)を1つずつ調べる
  21. 　　If Dat.row=1 then GoTo CONTINUE 　　　 '←ｾﾙの行位置が1(=ﾀｲﾄﾙ行)なら飛ばして次のｾﾙへ
  22. 　　If Title_Array(2, Dat.Column) <> "" Then 　　　 '←ｾﾙの行位置がカラで無かったら
  23. 　　　P_row=Title_Array(2, Dat.Column) - P_row_Max 　　　 '←配列の2行目の値(行位置)
  24. 　　　P_col=Title_Array(3, Dat.Column) - P_col_Min + 1 　　　 '←配列の3行目の値(列位置)
  25. 　　　P_array(P_row + (Dat.Row - 1) * P_row_count, P_col) = Dat.Value 　　　 '←配列にｾﾙ値を代入する
  26. 　　End If
  27. 　CONTINUE: 　　　 '←調べるセルがタイトル行だった時にはここへ飛ぶ
  28. 　Next Dat
  30. 　Range(P_start_cell, P_start_cell.Offset(UBound(P_array, 1) - 1, UBound(P_array, 2) - 1)) = P_array　 '←配列を貼る
  31. End Sub
まず、２～６行目で宣言した変数がどう使われるかですが、下図の通り主にプリント用シートのタイトルの位置を確定し、その下にデータを貼り付ける位置決めに使っています。なお、６行目の「P_start_cell」はわざわざ宣言するほどのものでもなく、「P_row_Max」と「P_col_Min」から簡単に求まるのですが、30行目のコードが非常に長くなってしまうので分けました。

宣言とタイトルの位置、データ貼り付けの位置を計算した後、18行目で一時記憶する配列の大きさを決めます。この時、プリント用シートのタイトルにカラ列等があったとしてもデータを詰めたりはしません。一気に貼り付けたい為です。
その配列にデータを代入していくのが25行目ですが、この時は貼り付ける位置を絶対位置ではなく「P_start_cell」を基準とした相対位置とするため、23,24行目でP_row_Maxなどを使って相対位置を出しています。
最後に30行目で「P_start_cell」を基準としてデータが入っている配列を一気に貼り付けます。この時、「＝の左辺と右辺は、同じサイズ」にすることが必要です。左辺が小さければデータが欠落しますし、左辺が大きければデータが無い部分に「#N/A」が貼り付けられてしまいます。 貼り付けサイズの計算方法はいくつか考えられますが、30行目のように右辺の貼り付けるサイズをUboundで取り出して指定すれば間違いはありません。

また、なんらかの事情で貼り付ける範囲と配列の行と列が違ってしまう場合がありますが、そういった場合にはワークシート関数の「TRANSPOSE」を使って貼り付けるデータの行と列を入れ替えます。今回はこれを使うとデータがおかしく表示されますが、以下の様なイメージです。
  1. 　Range(P_start_cell, P_start_cell.Offset(UBound(P_array, 1) - 1, UBound(P_array, 2) - 1)) = WorksheetFunction.Transpose(P_array)


1-5．罫線をデータ側に引く

データは貼りつきましたので、今度は印刷の見栄えを良くするためと、複数行で１データの場合はデータの区切りが見易いように、タイトル部分と同じように罫線を引くことにします。
タイトル部をコピーし書式の貼り付けをしますが、罫線以外のセル色なども貼り付けられてしまうので、あとからパターンを削除しています。
「マクロの記録」でコードを記録し、コピー範囲・ペースト範囲の再設定と、無駄な部分を削除して罫線作成プロシージャを作れば簡単に出来ます。
  1. Sub Border_On()
  2. 　Dim P_row_array , P_col_array as Variant 　　 '←プリント用シートのタイトル行位置・列位置を入れる配列
  3. 　Dim P_row_Max,P_col_Min as Integer 　　　　 '←プリント用シートのタイトルの最下端行、最左端列
  4. 　Dim P_row,P_col as Integer 　　　　　　　　　 '←貼り付け配列の中の行と列
  5. 　Dim P_start_cell,P_end_cell As Range 　　　　　 '←貼り付ける左上のセル位置と右下のセル位置
  6. 　Dim P_start_title,P_end_title As Range 　　　　 '←タイトルの左上のセル位置と右下のセル位置
  8. 　With WorksheetFunction
  9. 　　P_row_array = .Index(Title_Array, 2, 0) 　　　 '←配列Title_Arrayから2行目（行位置）を取り出す
  10. 　　P_row_count = .Max(P_row_array) - .Min(P_row_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  11. 　　P_row_Max = .Max(P_row_array) 　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最下端行を計算
  12. 　　P_col_array = .Index(Title_Array, 3, 0) 　　　 '←配列Title_Arrayから3行目（列位置）を取り出す
  13. 　　P_col_count = .Max(P_col_array) - .Min(P_col_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ列数を計算
  14. 　　P_col_Min = .Min(P_col_array) 　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最左端列を計算
  15. 　End　With
  17. 　Set P_start_title = Print_Sh.Cells(P_row_Max - P_row_count + 1 , P_col_Min)
  18. 　Set P_end_title = Print_Sh.Cells(P_row_Max , P_col_Min + P_col_count -1)
  19. 　Set P_start_cell = Print_Sh.Cells(P_row_Max + 1, P_col_Min)
  20. 　Set P_end_cell = Print_Sh.Cells(P_row_Max + (Data_Sh.UsedRange.Rows.Count - 1) * P_row_count , P_col_Min + P_col_count - 1)
  22. 　Range(P_start_title , P_end_title).Copy 　　 '←タイトル部をコピー
  24. 　Range(P_start_cell , P_end_cell).PasteSpecial Paste:=xlPasteFormats 　　 '←データ部に書式として貼り付け
  25. 　Range(P_start_cell , P_end_cell).Interior.Pattern = xlNone 　　 '←データ部のパターン（セル色など）を消す
  26. 　Application.CutCopyMode = False
  27. End Sub
メインプロシージャへ「罫線引きのプロシージャ」呼び出しを追加。
  1. Sub Sh_Print() 　　　　　　　　　　　 '←メインプロシージャ
  2. 　Set Data_Sh = Sheets("sheet1")
  3. 　Set Print_Sh = Sheets("sheet2")
  4. 　Call Data_t
  5. 　Call Print_t
  6. 　Call Data_Copy
  7. 　Call Border_On 　　　　　　 '←罫線引きのプロシージャ呼び出しを追加
  8. End Sub

なんか「Data_Copyプロシージャ」の前半部分とほぼ同じで、資源の無駄というよりも、メンテナンス性が最悪という感じです。様々なプロシージャが同じような値を使うのであれば、宣言部で変数を宣言してPublic変数とするべきと思います。
別の方法としては「Data_Copyプロシージャの中に罫線引きのコードも書いてしまう」、「Data_Copyプロシージャから、Border_Onプロシージャを引数付きで呼び出す」などもあるでしょう。例えば引数付き呼び出しとは、こんな具合です。
  1. 　Call Border_On(P_row_count , P_row_Max ,P_col_count , P_col_Min , ・・・・)

しかしData_Copyプロシージャの中に記述してしまった後で「罫線は引きたくない」というユーザが出てきたらどうします？　「罫線だけのカラシートを印刷したい」なんていうユーザも居るかもしれません。
改造が容易なように、また不具合を発見し易いように、プロシージャはなるべく単機能で独立性を高くするのが重要です。しかしもう少し工程が残っていますので、何をPublicにするかは後で考える事にしましょう。

1-6．「印刷ボタン」から印刷をする

このアプリは、「印刷ボタン」を押すとデータ用シートのデータがプリント用シートにコピーされ印刷される　という謳い文句で始まりました。ですのでここで印刷ボタンを作り、それにメインマクロを登録します。


このままですと、データがコピーされ罫線が引かれて終わりです。「印刷ボタン」は、Excelの印刷コマンドでは無いので印刷機能は自分で作らないといけませんので、「印刷するのはSheet2なのでSheet2に移動」し、「印刷ダイアログ」を出します。メインプロシージャを示します。
  1. Sub Sh_Print() 　　　　　　　　　　　 '←メインプロシージャ
  2. 　Set Data_Sh = Sheets("sheet1")
  3. 　Set Print_Sh = Sheets("sheet2")
  4. 　Call Data_t
  5. 　Call Print_t
  6. 　Call Data_Copy
  7. 　Call Border_On
  8. 　Sheets("Sheet2").Activate
  9. 　ret = Application.Dialogs(xlDialogPrint).Show
  10. 　if ret = true then
  11. 　　Sheets("Sheet1").Activate
  12. 　End If
  13. End Sub

「Dialogs(xlDialogPrint).Show」は、印刷が完了したら「True」を、キャンセルされたら「Faluse」を返します。どういう動きにするかは用途次第ですが、ここでは印刷完了したら元の状態（プリント用シートはタイトルのみ存在）に戻すこととします。
Application.Dialogsプロパティを使用すると、Excelに組み込まれている250以上ダイアログボックスをVBAから開くことができます。の引数に従って様々なダイアログボックスを表示します。その中で「xlDialogPrint」は印刷画面を表示します。 、「xlDialogPrintPreview」はプリントビュー画面を表示します。

1-7．タイトル以外の罫線を消す

ここまでのプログラムで、データ用シートのデータはプリンタ用シートにコピーされ罫線まで引かれていますから、あとは印刷するだけです。印刷が終わったら元の状態（プリント用シートはタイトルのみの状態）に戻す必要があります。そうしないと、コピーしたデータそのものがタイトルと誤認されて誤動作を起こす可能性があります。
罫線を消すプロシージャを下記に示します。
  1. Sub Border_Off()
  2. 　Dim P_row_array , P_col_array as Variant 　　 '←プリント用シートのタイトル行位置・列位置を入れる配列
  3. 　Dim P_row_Max,P_col_Min as Integer 　　　　 '←プリント用シートのタイトルの最下端行、最左端列
  4. 　Dim P_row,P_col as Integer 　　　　　 '←貼り付け配列の中の行と列
  5. 　Dim P_start_cell,P_end_cell As Range 　　　　　 '←貼り付ける左上のセル位置と右下のセル位置
  6. 　Dim P_start_title,P_end_title As Range 　 　　　 '←タイトルの左上のセル位置と右下のセル位置
  8. 　With WorksheetFunction
  9. 　　P_row_array = .Index(Title_Array, 2, 0) 　　 '←配列Title_Arrayから2行目（行位置）を取り出す
  10. 　　P_row_count = .Max(P_row_array) - .Min(P_row_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  11. 　　P_row_Max = .Max(P_row_array) 　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最下端行を計算
  12. 　　P_col_array = .Index(Title_Array, 3, 0) 　　　 '←配列Title_Arrayから3行目（列位置）を取り出す
  13. 　　P_col_count = .Max(P_col_array) - .Min(P_col_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ列数を計算
  14. 　　P_col_Min = .Min(P_col_array) 　　　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最左端列を計算
  15. 　End　With
  17. 　Set P_start_title = Print_Sh.Cells(P_row_Max - P_row_count + 1 , P_col_Min)
  18. 　Set P_end_title = Print_Sh.Cells(P_row_Max , P_col_Min + P_col_count -1)
  19. 　Set P_start_cell = Print_Sh.Cells(P_row_Max + 1, P_col_Min)
  20. 　Set P_end_cell = Print_Sh.Cells(P_row_Max + (Data_Sh.UsedRange.Rows.Count - 1) * P_row_count , P_col_Min + P_col_count - 1)
  22. 　Range(P_start_cell , P_end_cell).ClearFormats
  23. End Sub
御覧の通り「Data_Copyプロシージャ」の前半部分とほぼ同じ事は変わりません。異なるのは22行目でデータ範囲の書式（罫線を含む）を「ClearFormats」で消しています。また「Range(P_start_cell , P_end_cell).Borders.LineStyle = xlNone」を使用すると、結合（Merge）しているセルも元に戻してくれますので、今回のような場合にはより適していると思われます。
ちなみに「マクロの記録」を使って記録すると以下のようなコードを吐き出しますが、これよりは「ClearFormats」や「Borders.LineStyle = xlNone」の方が分かり易いのではないでしょうか。
  1. 　With Range(P_start_cell , P_end_cell)
  2. 　　.Borders(xlDiagonalDown).LineStyle = xlNone
  3. 　　.Borders(xlDiagonalUp).LineStyle = xlNone
  4. 　　.Borders(xlEdgeLeft).LineStyle = xlNone
  5. 　　.Borders(xlEdgeBottom).LineStyle = xlNone
  6. 　　.Borders(xlEdgeRight).LineStyle = xlNone
  7. 　　.Borders(xlInsideVertical).LineStyle = xlNone
  8. 　　.Borders(xlInsideHorizontal).LineStyle = xlNone
  9. 　End With


1-8．貼り付けたデータを消す

最後に貼り付けたデータを消すプロシージャです。上のモジュールとほぼ同じです。
  1. Sub Data_Off()
  2. 　Dim P_row_array , P_col_array as Variant 　　 '←プリント用シートのタイトル行位置・列位置を入れる配列
  3. 　Dim P_row_Max,P_col_Min as Integer 　　　　 '←プリント用シートのタイトルの最下端行、最左端列
  4. 　Dim P_row,P_col as Integer 　　　　　　　　　 '←貼り付け配列の中の行と列
  5. 　Dim P_start_cell,P_end_cell As Range 　　　　　 '←貼り付ける左上のセル位置と右下のセル位置
  6. 　Dim P_start_title,P_end_title As Range 　　　　 '←タイトルの左上のセル位置と右下のセル位置
  8. 　With WorksheetFunction
  9. 　　P_row_array = .Index(Title_Array, 2, 0) 　　　 '←配列Title_Arrayから2行目（行位置）を取り出す
  10. 　　P_row_count = .Max(P_row_array) - .Min(P_row_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  11. 　　P_row_Max = .Max(P_row_array) 　　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最下端行を計算
  12. 　　P_col_array = .Index(Title_Array, 3, 0) 　　　 '←配列Title_Arrayから3行目（列位置）を取り出す
  13. 　　P_col_count = .Max(P_col_array) - .Min(P_col_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ列数を計算
  14. 　　P_col_Min = .Min(P_col_array) 　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最左端列を計算
  15. 　End　With
  17. 　Set P_start_title = Print_Sh.Cells(P_row_Max - P_row_count + 1 , P_col_Min)
  18. 　Set P_end_title = Print_Sh.Cells(P_row_Max , P_col_Min + P_col_count -1)
  19. 　Set P_start_cell = Print_Sh.Cells(P_row_Max + 1, P_col_Min)
  20. 　Set P_end_cell = Print_Sh.Cells(P_row_Max + (Data_Sh.UsedRange.Rows.Count - 1) * P_row_count , P_col_Min + P_col_count - 1)
  22. 　Range(P_start_cell , P_end_cell).Value = ""
  23. End Sub
22行目の「データを消す」コードは、「Range(P_start_cell , P_end_cell).ClearContents」でもデータは削除されます。なお、ClearContentsでは、数式と値はクリアされますが、セルの書式と条件付き書式はそのまま残るので罫線は別に消さなくてはいけません。

メインプロシージャに「罫線削除」「貼り付けデータ削除」を組み込んで、一応完成です。
  1. Sub Sh_Print() 　　　　　　　　　　　 '←メインプロシージャ
  2. 　Set Data_Sh = Sheets("sheet1")
  3. 　Set Print_Sh = Sheets("sheet2")
  4. 　Call Data_t
  5. 　Call Print_t
  6. 　Call Data_Copy
  7. 　Call Border_On
  8. 　Sheets("Sheet2").Activate
  9. 　ret = Application.Dialogs(xlDialogPrint).Show
  10. 　if ret = true then
  11. 　　Call Border_Off 　　　'←罫線を消す
  12. 　　Call Data_Off 　　　'←貼り付けたデータを消す
  13. 　　Sheets("Sheet1").Activate
  14. 　End If
  15. End Sub

但し、印刷ダイアログボックスでキャンセルをした時にはプリント用シートに全てデータが残ることになります。「残っても良いじゃないか」と思われる方もいるかもしれませんが、こういうことは考えられないでしょうか。
　・次にデータを追加・修正する人が、プリント用シートのデータに手を加えてしまう。
　・データが残ったまま「印刷ボタン」を押すと、プリント用シートのデータもタイトルと判断して動作する。

こうなってしまうと二重管理も良いところで、もうどれが本物のデータなのか分からなくなります。こう成らない為には、
　対策1：印刷をしてもしなくても、プリント用シートのデータは消してしまう。（If文を使わない）
　対策2：プリント用シートを普段は非表示にし、印刷時のみ再表示させる。
　対策3：プリント用シートのタイトル範囲を印刷の都度UsedRange等で調べるのではなく、ブックに記録しておく。
　対策4：データの入っているプリント用シートはデータを変更できない様にする
などが考えられます。最も簡単なのは「対策1」で、無理やりマクロを中断されない限りプリント用シートにデータは残りません。対策2はタイトルの編集すら出来なくなってしまうのでシステムを作る意味がなくなってしまいます。
また、マクロ実行中にエラーが発生したりブックを閉じた際には、せっかく取得したタイトル範囲（配列Title_Array）は消えてしまいます。対策3は対策4とペアかもしれませんが、タイトル範囲を取得した時点で非表示シートに記録しておくか、セル範囲名として「名前の定義」をしておく方法が考えられます。

1-9．まとめ

以上をまとめたマクロを記述します。Public変数としてプリント用シートのタイトル部とデータ部の左上・右下のセル位置を追加し、またダブっているコードを出来るだけまとめて「Print_d」というプロシージャに集結させました。
  1. Dim Data_Sh, Print_Sh As Worksheet
  2. Dim Title_Array()
  3. Dim P_start_cell, P_end_cell As Range 　　　　　 '←貼り付ける左上のセル位置と右下のセル位置
  4. Dim P_start_title, P_end_title As Range 　　　　 '←タイトルの左上のセル位置と右下のセル位置
  6. Sub Sh_Print() 　　　　　　　　　　　　　　　　 '←メインプロシージャ
  7. 　Application.ScreenUpdating = False
  8. 　　Set Data_Sh = Sheets("sheet1")
  9. 　　Set Print_Sh = Sheets("sheet2")
  10. 　　Call Data_t 　　　　　　　　　　　　　　　 '←データ用シートのタイトルデータ取得しTitle_Arrayに格納
  11. 　　Call Print_t 　　　　　　　　　　　　　　　 '←プリント用シートのタイトルデータ取得しTitle_Arrayに格納
  12. 　　Call Print_d 　　　　　　　　　　　　　　　 '←プリント用シートのタイトルとデータの位置等をPublic変数に格納
  13. 　　Call Data_Copy 　　　　　　　　　　　　　 '←プリント用シートにデータをコピー
  14. 　　Call Border_On 　　　　　　　　　　　　　 '←データに合わせて罫線を引く
  15. 　　Sheets("Sheet2").Activate
  16. 　Application.ScreenUpdating = True
  17. 　　Application.Dialogs(xlDialogPrint).Show 　　 '←印刷用ダイアログボックス
  18. 　Application.ScreenUpdating = False
  19. 　　Sheets("Sheet1").Activate
  20. 　　Call Border_Off 　　　　　　　　　　　　　 '←プリント用シートの罫線を削除
  21. 　　Call Data_Off 　　　　　　　　　　　　　　 '←プリント用シートのデータを削除
  22. 　Application.ScreenUpdating = True
  23. End Sub
  26. Sub Data_t() 　　　　　　　　　　　　 '←データ用シートのタイトルを記憶
  27. 　Dim Last_Col As Range
  28. 　Dim i As Integer
  29. 　Set Last_Col = Data_Sh.Cells(1, Columns.Count).End(xlToLeft) 　　　　 '←タイトル行の右端セル
  30. 　ReDim Title_Array(1 To 3, 1 To Last_Col.Column) 　　　　　　　　　 '←タイトル項目数に合わせて配列を再構築
  31. 　i = 1
  32. 　For Each data_title In Range(Data_Sh.Cells(1, 1), Last_Col) 　　　　　 '←タイトル行を１つずつ取り出す
  33. 　　Title_Array(1, i) = data_title.Value 　　　 '←タイトル文字列を配列に代入
  34. 　　i = i + 1
  35. 　Next data_title
  36. End Sub
  39. Sub Print_t() 　　　　　　　　　 '←プリント用シートのタイトルを記憶
  40. 　Dim j As Integer
  41. 　For Each print_title In Print_Sh.UsedRange 　　　　 '←タイトル部分を１つずつ取り出す
  42. 　　For i = 1 To UBound(Title_Array, 2) 　　　 '←タイトル項目数分を繰り返す
  43. 　　　If Title_Array(1, i) = print_title.Value Then 　　　 '←データ用タイトルとプリント用タイトルが合えば実施
  44. 　　　　Title_Array(2, i) = print_title.Row 　　　 '←プリント用タイトルの行位置を配列の2番目に代入
  45. 　　　　Title_Array(3, i) = print_title.Column 　　　　 '←プリント用タイトルの列位置を配列の3番目に代入
  46. 　　　End If
  47. 　　Next i
  48. 　Next print_title
  49. End Sub
  52. Sub Print_d() 　　　　　 '←プリント用シートのタイトルとデータの位置等をPublic変数に格納
  53. 　Dim P_row_array, P_col_array As Variant 　　　　 '←プリント用シートのタイトル行位置・列位置を入れる配列
  54. 　Dim P_row_Max, P_col_Min As Integer 　　　　 '←プリント用シートのタイトルの最下端行、最左端列
  55. 　Dim P_row, P_col As Integer 　　　　　　　　　 '←貼り付け配列の中の行と列
  56. 　With WorksheetFunction
  57. 　　P_row_array = .Index(Title_Array, 2, 0) 　　 '←配列Title_Arrayから2行目（行位置）を取り出す
  58. 　　P_row_count = .Max(P_row_array) - .Min(P_row_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ行数を計算
  59. 　　P_row_Max = .Max(P_row_array) 　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最下端行を計算
  60. 　　P_col_array = .Index(Title_Array, 3, 0) 　　 '←配列Title_Arrayから3行目（列位置）を取り出す
  61. 　　P_col_count = .Max(P_col_array) - .Min(P_col_array) + 1 　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙ列数を計算
  62. 　　P_col_Min = .Min(P_col_array) 　　　　　　 '←ﾌﾟﾘﾝﾄ用ｼｰﾄのﾀｲﾄﾙの最左端列を計算
  63. 　End With
  64. 　Set P_start_title = Print_Sh.Cells(P_row_Max - P_row_count + 1, P_col_Min)
  65. 　Set P_end_title = Print_Sh.Cells(P_row_Max, P_col_Min + P_col_count - 1)
  66. 　Set P_start_cell = Print_Sh.Cells(P_row_Max + 1, P_col_Min)
  67. 　Set P_end_cell = Print_Sh.Cells(P_row_Max + (Data_Sh.UsedRange.Rows.Count - 1) * P_row_count, P_col_Min + P_col_count - 1)
  68. End Sub
  71. Sub Data_Copy()
  72. 　ReDim P_array(1 To (P_end_cell.Row - P_start_cell.Row + 1), 1 To (P_end_title.Column - P_start_title.Column + 1))
  73. 　For Each Dat In Data_Sh.UsedRange 　　　 '←ﾃﾞｰﾀ用ｼｰﾄの使われたｾﾙ(ﾀｲﾄﾙ行含)を1つずつ調べる
  74. 　　If Dat.Row = 1 Then GoTo CONTINUE 　　 '←ｾﾙの行位置が1(=ﾀｲﾄﾙ行)なら飛ばして次のｾﾙへ
  75. 　　If Title_Array(2, Dat.Column) <> "" Then 　　 '←ｾﾙの行位置がカラで無かったら
  76. 　　　P_row = Title_Array(2, Dat.Column) - P_end_title.Row 　　 '←配列の2行目の値(行位置)
  77. 　　　P_col = Title_Array(3, Dat.Column) - P_start_title.Column + 1 　　　 '←配列の3行目の値(列位置)
  78. 　　　P_array(P_row + (Dat.Row - 1) * (P_end_title.Row - P_start_title.Row + 1), P_col) = Dat.Value 　 '←配列にｾﾙ値を代入
  79. 　　End If
  80. CONTINUE: 　　　　 '←調べるセルがタイトル行だった時にはここへ飛ぶ
  81. 　Next Dat
  82. 　Range(P_start_cell, P_end_cell) = P_array 　 '←配列を貼る
  83. End Sub
  86. Sub Border_On() 　　　　　　　　　　　　　 '←プリント用シートでデータに合わせて罫線を引く
  87. 　Range(P_start_title, P_end_title).Copy 　　　 '←タイトル部の罫線をコピーする
  88. 　Range(P_start_cell, P_end_cell).PasteSpecial Paste:=xlPasteFormats 　　 '←データ部に書式として貼り付け
  89. 　Range(P_start_cell, P_end_cell).Interior.Pattern = xlNone 　　　　　　 '←パターン（セル色など）を削除
  90. 　Application.CutCopyMode = False
  91. End Sub
  94. Sub Border_Off() 　　　　　　　　　　　　　 '←プリント用シートのデータ部分の罫線を削除する
  95. 　Range(P_start_cell, P_end_cell).ClearFormats
  96. End Sub
  99. Sub Data_Off() 　　　　　　　　　　　　　 '←プリント用シートに貼ったデータを削除する
  100. 　Range(P_start_cell, P_end_cell).Value = ""
  101. End Sub



上記マクロを記載したExcelファイル（it-009.xlsm）
セキュリティ向上を目的として「インターネット経由でダウンロードしたOfficeファイル（Excel等）のマクロは、既定でブロック」されるようにOfficeアプリケーションの既定動作が変更になりました。（2022年4月より切替開始）
解除の方法については「ダウンロードファイルのブロック解除方法」を参照下さい。