[[20080207143349]]　『コピー貼付け時に印刷範囲を指定』（はっぴー）　ページの最後に飛ぶ

『コピー貼付け時に印刷範囲を指定』（はっぴー）

 ＡファイルのシートをコピーしＢファイルのシートに貼付けをする自動マクロを設定して
 います。この時、コピーする行数がいつも同じ行数であれば貼付けされたシートの行数も
 同じになるため印刷時には同じ印刷範囲となりますが、Ａファイルのシートの行数が毎回
 変わる場合はその都度Ｂファイルのシートで印刷範囲の再設定をする必要があります。
 毎回設定しなくても貼付けと同時に印刷範囲も行数に合わせて設定されるようにできない
 ものでしょうか。ちなみにこの例では列数は不変ですが仮に列数が変わる場合も教えてく
 ださい。

 こんなものを仕掛けておいたらどうでしょうか。(ROUGE)

 With Workbooks("B.xls").Sheets("Sheet1")
  .PageSetup.PrintArea = .UsedRange.Address
 End With

 ROUNGEさんご回答ありがとうございました。
 しかしながら、私はマクロは素人でよくわかりません。
 自動でマクロを作成するのは分かりますが、この仕掛けをどの部分に挿入すればいいのか
 皆目見当がつきません。申し訳ありませんがもう少し詳しく教えていただけないでしょうか。
 はっぴー

 見逃していました。
 お返事遅くなり申し訳ございません。

 貼り付けのコードの下に上記コードを入れ込みます。
 (ROUGE)

 ROUNGEさんご回答ありがとうございました。
 しかしながら、私の質問が言葉足らずでしたので肝心なところが抜けていました。
 申し訳ありませんが再度整理してご質問します。

 Ａファイルのシート１の形式ですが既に50行目まで罫線が入っています。シートの
 データは更新毎に、20行だったり30行だったり時には60行だったりします。
 罫線がない場合はご回答のとおりにするとうまくいくのですが、罫線があるためＢ
 ファイルでは50行目までが印刷範囲として固定されてしまいます。Ａファイルに50
 行目まで罫線があっても実際にセルに値がある行（20行、30行等）までがコピーさ
 れ、Ｂファイルに貼り付けられて、印刷範囲もその都度貼り付けられた行数に合わ
 せて変更されるようにしたいのですが、とても難しいでしょうか。

 横から失礼します。(回答にあらず）
ROUNGE　さんではなく、ROUGEさんですよ～　　　　（ぷーのすけ）

 苦し紛れの処理案（汗
 (ROUNGE) ん？
'----
Dim rng As Range, wf As WorksheetFunction
Dim cl() As Long, rw() As Long, i As Long
With Workbooks("B.xls").Sheets("Sheet1")
    ReDim cl(1 To .Rows.Count)
    ReDim rw(1 To .Columns.Count)
    i = 0
    For Each rng In .Range(.Cells(.Rows.Count, 1), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        rw(i) = rng.End(xlUp).Row
    Next
    i = 0
    For Each rng In .Range(.Cells(1, .Columns.Count), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        cl(i) = rng.End(xlToLeft).Column
    Next
    .PageSetup.PrintArea = .Range("A1", .Cells(wf.Max(rw), wf.Max(cl))).Address
End With

 ROUGEさん　お名前を間違えて失礼しました。
 ご回答のとおり実行しましたがエラーとなりました。

 　実行エラー'91':
   ｵﾌﾞｼﾞｪｸﾄ変数またはWithﾌﾞﾛｯｸ変数が設定されていません。

   箇所：下から２行目
 　　　　.PageSetup・・・・・・・の一行

 すみません教えてください。

 携帯からなので検証できませんが、
 Dim wf As WorksheetFunction
 を省略していませんか？
 (ROUGE)

 申し訳ありません。
 何行目を確認すればよいでしょうか。
 ご指摘のコードは見当たりませんが挿入するとしたらどこの場所ですか。
 ちなみに、End With　の１行上ではエラーになりました。

 どうもWorksheetFunctionを省略したのがまずかったみたいです。(ROUGE)
　
Dim rng As Range
Dim cl() As Long, rw() As Long, i As Long
With Workbooks("B.xls").Sheets("Sheet1")
    ReDim cl(1 To .Rows.Count)
    ReDim rw(1 To .Columns.Count)
    i = 0
    For Each rng In .Range(.Cells(.Rows.Count, 1), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        rw(i) = rng.End(xlUp).Row
    Next
    i = 0
    For Each rng In .Range(.Cells(1, .Columns.Count), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        cl(i) = rng.End(xlToLeft).Column
    Next
    .PageSetup.PrintArea = Range("A1", Cells(WorksheetFunction.Max(rw), _
        WorksheetFunction.Max(cl))).Address
End With

 ROUGEさんありがとうございます。
 ただ、実行すると「型が一致しません。」のエラーメッセージが表示されます。
 なにか他に問題があるのでしょうか？

 コードのどの部分でエラーになりますか？
 (ROUGE)

 .PageSetup.PrintArea = Range("A1", Cells(WorksheetFunction.Max(rw), _
        WorksheetFunction.Max(cl))).Address

 の部分が黄色表示です。

    .PageSetup.PrintArea = .Range("A1", .Cells(WorksheetFunction.Max(rw), _
        WorksheetFunction.Max(cl))).Address

 としたらどうなりますか？(ROUGE)

 同じエラーメッセージが表示され、同じ部分が黄色表示となりました。

 こちらではエラーにならないんですよね。。。orz
 原因が分からないとどうにも対処しようがありません。
 ちなみに、新規Bookで対象となるオブジェクトをSheets("Sheet1")とした場合、同じエラーはでますか？
 (ROUGE)

 お忙しいのにすみません。
 モジュールに書き込まれた内容は下記のとおりです。
 ROUGEさんに教えてもらった部分以外は自動マクロで作成しています。
 申し訳ありませんが点検をお願いします。

 Cells.Select
    Selection.Copy
    Windows("B.xls").Activate
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=False
    Range("A1").Select
    Windows("A.xls").Activate
    Range("A1").Select
    Application.CutCopyMode = False
Dim rng As Range
Dim cl() As Long, rw() As Long, i As Long
With Workbooks("B.xls").Sheets("Sheet1")
    ReDim cl(1 To .Rows.Count)
    ReDim rw(1 To .Columns.Count)
    i = 0
    For Each rng In .Range(.Cells(.Rows.Count, 1), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        rw(i) = rng.End(xlUp).Row
    Next
    i = 0
    For Each rng In .Range(.Cells(1, .Columns.Count), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        cl(i) = rng.End(xlToLeft).Column
    Next
    .PageSetup.PrintArea = .Range("A1", .Cells(WorksheetFunction.Max(rw), _
        WorksheetFunction.Max(cl))).Address

End With

End Sub

 これでどうでしょうか。(ROUGE)
'----
Dim rng As Range
Dim cl() As Long, rw() As Long, i As Long
With Workbooks("B.xls").Sheets("Sheet1")
    .Cells.Value = ActiveSheet.Cells.Value
    ReDim cl(1 To .Rows.Count)
    ReDim rw(1 To .Columns.Count)
    i = 0
    For Each rng In .Range(.Cells(.Rows.Count, 1), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        rw(i) = rng.End(xlUp).Row
    Next
    i = 0
    For Each rng In .Range(.Cells(1, .Columns.Count), _
        .Cells(.Rows.Count, .Columns.Count))
        i = i + 1
        cl(i) = rng.End(xlToLeft).Column
    Next
    .PageSetup.PrintArea = .Range("A1", .Cells(WorksheetFunction.Max(rw), _
        WorksheetFunction.Max(cl))).Address
End With

 同じエラーメッセージが表示されます。同じ部分が黄色表示となります。

 エラーの原因が分からないんですよね。。。

 ところで、コピー先のBook名は、B.xls、Sheet名は、Sheet1　ですか？

 (ROUGE)

 そのとおりです。
 モジュールの内容すべてを載せていますので、間違いないと思います。
 申し訳ないですがよろしくお願いします。

 以下でどのようなメッセージが出ますか？(ROUGE)
'----
Dim rw As Long, cl As Long
With Workbooks("B.xls").Sheets("Sheet1")
    .Cells.Value = ActiveSheet.Cells.Value
    rw = .Rows.Count
    Do While WorksheetFunction.CountBlank _
        (.Cells(rw, 1).EntireRow) = .Columns.Count
        rw = rw - 1
        If rw = 1 Then Exit Do
    Loop
    cl = .Columns.Count
    Do While WorksheetFunction.CountBlank _
        (.Cells(1, cl).EntireColumn) = .Rows.Count
        cl = cl - 1
        If cl = 1 Then Exit Do
    Loop
    MsgBox .Range("A1", Cells(rw, cl)).Address
    '.PageSetup.PrintArea = .Range("A1", Cells(rw, cl)).Address
End With

 「アプリケーション定義またはオブジェクト定義のエラーです。」とメッセージが
 表示されました。
 MsgBox .Range("A1", Cells(rw, cl)).Address　部分が黄色表示です。

 横から失礼します。
 Bブックに貼り付けたデータ範囲内の行列に
 全くの空白行や空白列が無いのであれば
 UsedRange ではなく CurrentRegionを使うのでは駄目ですかね？

 (HANA)

 おっ！そうですね。
 CurrentRegionがいいですね。

 とすると、
　
With Workbooks("B.xls").Sheets("Sheet1")
    .Clear
    ActiveSheet.Range("A1").CurrentRegion.Copy .Range("A1")
    Application.CutCopyMode = False
End With
　
でよいかも。
(ROUGE)

  Cells.Select
     Selection.Copy
     Windows("B.xls").Activate
     Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
         , Transpose:=False
     Range("A1").Select
     Windows("A.xls").Activate
     Range("A1").Select
     Application.CutCopyMode = False
 With Workbooks("B.xls").Sheets("Sheet1")
     .Clear
     ActiveSheet.Range("A1").CurrentRegion.Copy .Range("A1")
     Application.CutCopyMode = False
 End With
 End Sub

 の .Clear が黄色表示され、「オブジェクトは、このプロパティまたはメソッドをサポートして
 いません。」のエラーメッセージが表示されます。

 ごめんなさい！！！
 いっこプロパティ忘れていました。
 コピーのコードも入れてありますので、これだけでOK（のはず）です。
 (ROUGE)

 With Workbooks("B.xls").Sheets("Sheet1")
     .Cells.Clear
     ActiveSheet.Range("A1").CurrentRegion.Copy .Range("A1")
     Application.CutCopyMode = False
 End With

 ROUGEさん、大変！
 Cells.Clear
 だと、ActiveSheet.Cells.Clear になりませんか？
 違っていたらごめんなさい。
 (seiya)

 うっ！大変だ！！修正！！！(ROUGE)

 ROUGEさん　お忙しいところすみません。
 その後、解決策は見つかったでしょうか。

 あれ？上記コードではだめでしたか？
 (ROUGE)

 seiyaさんの言われるとおり、Ａファイルのシートが白紙になってしまいます。
 どうしてもうまくいきません。

 いや、seiyaさんの指摘に対応して、コードを直接修正しています。
 (ROUGE)

 ROUGEさん　ご指摘のとおりやってみましたが、Ｂファイルのシートの印刷範囲はＡファイルのシートの
 入力セル範囲の行数を変えても同じ範囲で固定しています。

　　　Ａのシートのデータが１０行目までならＢのシートの１０行目までが印刷範囲に

　　　Ａのシートのデータが１５行目までならＢのシートの１５行目までが印刷範囲に

 と言う具合になれば成功なんですが。

 えっと、上記コードはB.xlsのSheet1の内容をすべて消去してから、アクティブシート（A.xlsファイル？）
 のA1から続く範囲をB.xlsのSheet1に貼り付けています。
 これで対応できないとなると、σ(^-^;)には打つ手なしです。。。orz
 (ROUGE)

 ROUGEさん　ActiveSheet.Cells.Clear　にするとＡファイルは消去されます。
 したがって、.Cells.Clear　でやると上記のようになります。
 いずれにしてもＢファイルの印刷範囲は固定したままで変化ありません。

 え？提示したコードには　ActiveSheet.Cells.Clear　はありませんよ。
 Workbooks("B.xls").Sheets("Sheet1").Cells.Clear　はありますが。
 (ROUGE)

 またまた横から失礼します。

 ROUGEさんのコードは
 印刷範囲を変更する物では【有りません】
 その点はご理解して頂けておりますか？

 これまでは
 例えば、ブックAのデータがA1:A3の場合でも
 このシート全体を選択し、コピー
 ブックBのシートに貼り付けを行い
 印刷範囲を設定して居られたのですよね？

 その理由として、A1:A50まで罫線が引かれており
 印刷したときに罫線だけのA4:A50が印刷されて仕舞う為ですよね。

 ROUGEさんのコードは
 ブックAのデータがA1:A3の範囲しか無い場合は
 その範囲だけをブックBに貼り付ける

 と言う物です。
 A1:A3の範囲しか貼り付けられないので、
 印刷範囲の設定をする必要も無いと思います。

 こちらからははっぴーさんのブックの状況が分かりませんので
 少し教えていただきたいのですが
 １．ROUGEさんのマクロを実行したときに、ブックAのデータが有る範囲のみが
 　　ブックBに貼り付いているか？
 　　それとも、罫線だけのセルも貼り付いているか？

 ２．１番でデータの有る範囲のみが貼り付いている場合。
 　　印刷範囲の設定を解除した状態で印刷すると
 　　欲しい場所だけが印刷されるか？

 ３．１番で罫線だけのセルも貼り付いている場合。
 　　ブックAのデータがどの様に表示されている物か。
 　　（手入力・インポート・関数で参照　等）
 　　また、何の範囲を印刷範囲とするのか。
 　　（A列が「""」になったとき　等）

 まずは、ROUGEさんのコードに手を加えず
 データの入ったブックA　と、Sheet1の有るブックBを作成し
 ブックAの標準モジュールにコードをペースト
 ブックAのデータの有るシートをアクティブにした状態で
 マクロを実行した結果のご報告を載せてみてください。

 (HANA)

 下から失礼します。
こんな感じではどうでそ。
Sub Test()
Dim Obj_LastRow As Object, Obj_LastCol As Object
Dim lng_LastRow As Long, lng_LastCol As Long
Dim str_LastRng As String
With Workbooks("B.xls").Sheets("Sheet1")
    'ブックAのシート1の全てを、ブックBのシート1に貼り付け
    Workbooks("A.xls").Sheets("Sheet1").Cells.Copy Destination:=.Range("A1")
    'ブックBの入力された最終行を変数に代入
    Set Obj_LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious)
    'ブックBの入力された最終列を変数に代入
    Set Obj_LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious)
    '何も入力されていなかったら処理を終了
    If Obj_LastRow Is Nothing Then Exit Sub
    '最終行の行数を変数に代入
    lng_LastRow = Obj_LastRow.Row
    '最終列の列数を変数に代入
    lng_LastCol = Obj_LastCol.Column
    '最終列、最終行（最後のセル番地）を変数に代入
    str_LastRng = Cells(lng_LastRow, lng_LastCol).Address
    'シートBの入力された範囲を印刷範囲に設定
    .PageSetup.PrintArea = "$A$1:" & str_LastRng
End With
Set Obj_LastRow = Nothing
Set Obj_LastCol = Nothing
End Sub

 （川野鮎太郎）

 HANAさん　お世話になります。
 ご質問についてお答えします。
 １．については「データが有る範囲のみ」が貼り付いています。
 ２．については「欲しい場所だけ印刷」されています。

 Ａのシートのデータのある行数を変えても、欲しい場所だけが貼り付けられます。

 川野鮎太郎さん　お世話になります。
 ご教示いただいたコードを貼付けてみましたが、Ａのシートのデータのない罫線のみの
 50行目までＢのシートに貼り付きます。

 >Ａのシートのデータのない罫線のみの50行目までＢのシートに貼り付きます
 そんなコードは書いてないと思うんですが・・・（多分）
 紛らわしくなっても困るでしょうから、私のは( ｡･･)/⌒□ポイ　しておいてください。
 （川野鮎太郎）

 ＞Ａのシートのデータのある行数を変えても、
 ＞欲しい場所だけが貼り付けられます。
 と言う事ですが、それで　その動きは
 ご希望のことを満たしていませんでしょうか？

 あくまでも、印刷範囲の設定を行いたいのでしょうか？
 それとも、実際は他の処理も行っており　利用できないのでしょうか？

 (HANA)

 貼り付けられた「Ｂファイル」のデータは毎回行数が変わるため印刷範囲の設定も新たな行数の範囲となるよう
 になればと思っています。
 また、お尋ねしているファイルではシート１のみですが実際に使っているものはシートが複数あるため各シート
 の最後にこのコードを挿入するのかすべての最後に挿入するのかも併せて教えてください。

 印刷したい部分しかコピペしていないので、印刷範囲の設定は不要だと思います。
 シートが複数になっても仕様が一緒なのであれば、対応も一緒になりますよ。
 (ROUGE)

 ROUGEさんよろしくお願いします。
 これまでＡファイルのシート１での例としてお聞きしましたが、実際にこちらで使用するファ 
 イルには
 複数のシートが作成されています。したがって、［With Workbooks("B.xls").Sheets  ("Sheet1")］の
 Sheetの部分についてはどのように変更すればよろしいでしょうか。

 最初に
 ＞ＡファイルのシートをコピーしＢファイルのシートに貼付けをする自動マクロを設定しています。
 と書いて居られますがその時はどの様にしていたのですか？

 (HANA)

 お尋ねの件ですが、以下のようにマクロ設定しています。

 Selection.Copy
    Windows("B.xls").Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Windows("A.xls").Activate
    Sheets("３１").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("B.xls").Activate
    Sheets("３１").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Windows("A.xls").Activate
    Sheets("３２").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("B.xls").Activate
    Sheets("３２").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Windows("A.xls").Activate
    Sheets("３３").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("B.xls").Activate
    Sheets("３３").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Windows("A.xls").Activate
    Sheets("３４").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("B.xls").Activate
    Sheets("３４").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
　　End Sub

 コードだけでは良く分かりません。
 どこをコピーして、どこに貼り付けるコードなのですか？
 言葉も使って教えて下さい。

 ↑がマクロの記録のコードの場合は
 どの様な手順を記録にしたのか教えて下さい。

 (HANA)

 自動マクロを利用して、Ａファイルの“３１シート全体”をコピーし、Ｂファイルの“３１シート全体”に
 値の貼付け（Ａファイルには関数を使用した数値があるため）で貼り付けています。
 以下同様に“３２シート”“３３シート”を貼り付けています。

 こんなので上手く行きますか？

 '------
Dim sn, msn
sn = Array("３１", "３２", "３３", "３４")
For Each msn In sn
With Workbooks("B.xls").Sheets(msn)
    .Cells.Clear
    Workbooks("A.xls").Sheets(msn).Range("A1").CurrentRegion.Copy .Range("A1")
    .Range("A1").CurrentRegion.Value = .Range("A1").CurrentRegion.Value
    Application.CutCopyMode = False
End With
Next
 '------

 (HANA)

コメント返信：

[ 一覧(最新更新順) ]

[[20080207143349]] 『コピー貼付け時に印刷範囲を指定』（はっぴー） ページの最後に飛ぶ

[[20080207143349]]　『コピー貼付け時に印刷範囲を指定』（はっぴー）　ページの最後に飛ぶ