抽出印刷マクロ

質問

sheet1に一行目は項目欄で　A1氏名、B1山、C1川、D1谷、E1空、・・・L1合計　があり、A列に各人の氏名があり各項目欄に金額があったりなかったりする表があります。
sheet2には封筒サイズを設定してこれを印刷します。
ここで、sheet2のA1に氏名を印刷します。sheet1の項目中に1つの金額しかない人の分はA1に氏名、A2に該当の項目名、B2に金額、A3に合計の文字、B3に合計金額、罫線をA1:B3に引き印刷。
金額が3項目にある人(山、谷、空)は、A1に氏名、A2に山、B2に金額、A3に谷、B3に金額、A4に空、B4に金額、A5に合計、B5に合計金額、罫線をA1:B5に引き印刷。このように順次印刷するマクロの記述方を教えてください。お願いします。

回答No.3

merlionXX · ベストアンサー

> 質問の中で　ここでsheet2のA1に氏名を印刷しますは、ここでsheet2のA2に氏名を印刷しますです。そのためA3から項目名が始まります。
> 教えていただきました手直しの分で項目名が表示されません。

質問に書いた配置に誤りがあったということですね？
ただ、Sheet2のA1に名前を表示しようがA2に表示しようが、そのすぐ下から項目名が表示されるはずです。
それが表示されないということは、Sheet1の方の配置説明も違っているのではないですか？
前回の回答ではhoshi7777さんが書いた通り、Sheet1の１行目が項目欄で　A1が氏名～以下各項目としてコードを書きましたが、これも１行ずれてるんじゃないですか？
そうであれば、以下のマクロをお試しください。

Sub test02()
Dim s2 As Worksheet, x As Long, y As Long, i As Long, n As Integer, c As Range '変数宣言
Set s2 = Sheets("Sheet2") 'Sheet2をs2とする
With Sheets("Sheet1") 'Sheet1において
x = .Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行を取得しxに代入
y = s2.Cells(Rows.Count, "A").End(xlUp).Row 's2,A列最終行を取得しyに代入
For i = 3 To x '3～xまでをiに代入
With s2 's2において
.Range("A2:B" & y).ClearContents 'データクリア
.Range("A2:B" & y).Borders.LineStyle = xlNone '罫線クリア
End With
s2.Cells(2, "A").Value = .Cells(i, "A").Value '氏名転記
n = 2 'ｎに2を代入
For Each c In .Range(.Cells(i, "B"), .Cells(i, "L")) 'B～L列のi行各セル
If TypeName(c.Value) = "Double" Then '数値であれば
n = n + 1 'ｎに1を加算
s2.Cells(n, "A").Value = .Cells(2, c.Column).Value '項目名転記
s2.Cells(n, "B").Value = c.Value '数値転記
End If
Next c '次セルへ進み繰り返し
With s2 's2において
.Cells(n + 1, "A").Value = "合計" '文字入力
.Cells(n + 1, "B").Formula = "=SUM(" & .Range(.Cells(3, "B"), .Cells(n, "B")).Address & ")" '合計計算式入力
.Range(.Cells(2, "A"), .Cells(n + 1, "B")).Borders.LineStyle = xlContinuous '罫線作成
.PrintPreview '印刷プレビュー
End With
Next i '次行に進み繰り返し
End With
End Sub

お礼

何回もお手数おかけして申し訳ありませんでした。
本当にありがとうございました。
大変勉強になりました。

補足

お手数掛けています。本当に申し訳ありません。質問でsheet1は一行目が項目名としていましたが。一行目は空欄で二行目が項目名でした。
そのため項目名が表示されなかったものです。本当に申し訳ありませんでした。よろしくお願いします。

回答No.2

merlionXX

merlionXXです。
先ほどのでも動きますが、少しだけ手直ししました。
なお、印刷はテストのためプレビューにしてあります。
コードにコメントもつけておきました。

Sub test01()
Dim s2 As Worksheet, x As Long, i As Long, n As Integer, c As Range '変数宣言
Set s2 = Sheets("Sheet2") 'Sheet2をs2とする
With Sheets("Sheet1") 'Sheet1において
x = .Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行を取得しxに代入
For i = 2 To x '2～xまでをiに代入
With s2 's2において
.Range("A1:B5").ClearContents 'データクリア
.Range("A1:B5").Borders.LineStyle = xlNone '罫線クリア
End With
s2.Cells(1, "A").Value = .Cells(i, "A").Value '氏名転記
n = 1 'ｎに1を代入
For Each c In .Range(.Cells(i, "B"), .Cells(i, "L")) 'B～L列のi行各セル
If TypeName(c.Value) = "Double" Then '数値であれば
n = n + 1 'ｎに1を加算
s2.Cells(n, "A").Value = c.Offset(1 - i).Value '項目名転記
s2.Cells(n, "B").Value = c.Value '数値転記
End If
Next c '次セルへ進み繰り返し
With s2 's2において
.Cells(n + 1, "A").Value = "合計" '文字入力
.Cells(n + 1, "B").Formula = "=SUM(" & .Range(.Cells(2, "B"), .Cells(n, "B")).Address & ")" '合計計算式入力
.Range(.Cells(1, "A"), .Cells(n + 1, "B")).Borders.LineStyle = xlContinuous '罫線作成
.PrintPreview '印刷プレビュー
End With
Next i '次行に進み繰り返し
End With
End Sub

補足

ありがとうございました。質問の中で　ここでsheet2のA1に氏名を印刷しますは、ここでsheet2のA2に氏名を印刷しますです。そのためA3から項目名が始まります。教えていただきました手直しの分で項目名が表示されません。よろしくお願いします。

回答No.1

merlionXX

一例です。

Sub test01()
Set s2 = Sheets("Sheet2")
With Sheets("Sheet1")
x = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To x
With s2
.Range("A1:B5").ClearContents
.Range("A1:B5").Borders.LineStyle = xlNone
End With
n = 1
For Each c In .Range(.Cells(i, "B"), .Cells(i, "L"))
s2.Cells(1, "A").Value = .Cells(i, "A").Value
If c.Value <> "" Then
n = n + 1
s2.Cells(n, "A").Value = c.Offset(-i + 1).Value
s2.Cells(n, "B").Value = c.Value
End If
Next c
s2.Cells(n + 1, "A").Value = "合計"
s2.Cells(n + 1, "B").FormulaLocal = "=SUM(" & s2.Range(s2.Cells(2, "B"), s2.Cells(n, "B")).Address & ")"
s2.Range(s2.Cells(1, "A"), s2.Cells(n + 1, "B")).Borders.LineStyle = xlContinuous
s2.PrintOut
Next i
End With
End Sub