Results of 1 - 1 of about 296 for 差し込み印刷 (0.002 sec.)
- [[20180402234321]]
- #score: 8241
- @digest: 28233ea4f379b78c3dfa2fa1402f0b70
- @id: 75978
- @mdate: 2018-04-12T00:31:49Z
- @size: 52953
- @type: text/plain
- #keywords: mypath2 (229837), 細作 (160785), base2 (97381), 出列 (73430), 事│ (68508), 成用 (55547), 用. (51920), ixrow (45637), 明細 (28462), mybook (25469), 商事 (23674), 囲. (19369), タ範 (18771), 囲= (12305), thisworkbook (11727), 企業 (11615), │ (11323), workbooks (9557), 印刷 (8652), lastrow (8423), ロン (8044), sheets (7487), range (6966), currentregion (6838), ws1 (6660), ws2 (6651), 2018 (6642), xlsx (6536), ル範 (6041), デー (5788), 抽出 (5708), 終行 (5577)
- 『印刷ツール』（マクロン）
企業情報や売り上げのデータが入っているシート1（元ファイル）があります A列は企業IDです シート2に印刷したい企業IDをA列に入れます。 同じフォルダーの中に別のBOOK「明細作成用」のExcelファイルがあります。 元ファイルから順次企業IDごとに明細BOOKに必要なデータを抜粋し 明細作成用に転記し印刷したいです。 例 元ファイル 企業ID、企業名、 住所、売り上げ日付け、品番、個数、金額 001 田中商事 東京 20181002 G01 2 300 002 佐藤商事 東京 20181002 G01 2 300 001 田中商事 東京 20181005 C01 2 600 シート2のA列に 001 005 300 と入れると 明細に 企業ID、企業名、 売り上げ日付け、品番、個数、金額 001 田中商事 20181002 G01 2 300 001 田中商事 20181005 C01 2 600 が、はいり印刷されるようにしたいです 実際には元ファイルには明細には不必要なデータもあるので、明細に必要な ものだけ抜粋したいです、 また明細はマックス6行までしかはいらないため7行以上ある場合は 2枚・3枚と枚数が増えます。 lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 For i = 2 To lastRow こんな感じを使用しつつ、VLOOKUPは使用しないで、配列とか使用して できればとおもっているのですが、全くお手上げの状態です どなたか構文をお願いいたします。 ＜ 使用 Excel:Excel2013、使用 OS:Windows8 ＞ ---- う〜ん 断片&やげやりすぎてよくわからないです。 出来たところまででよいのでアップしてみては? とりあえず、、、、 lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 For i = 2 To lastRow は1行にして For i = 2 To ws1.Range("A" & Rows.Count).End(xlUp).Row 'A列2行目〜最終行まで順番に処理 でいいでしょう。 ＞シート2のA列に ＞001 ＞005 ＞300 「005」、「300」は何のための数字なのかわからないのでそれも補足説明していただかないと、Excel君にも回答者にも状況が伝わらないと思います。 （もこな2） 2018/04/03(火) 00:15 ---- コメントありがとうございました。 シート2のA列に 入力してある 001 005 300 はそれぞれ企業IDです。 例 001 田中商事 005 渡辺商事 300 鈴木商事といった感じです。 とりあえずシート1（元ファイル）から必要な列の抽出は以下でできるようになりました。 Sub a_列抽出() Dim データ範囲 As Range Dim 抽出列 As Variant Dim n As Long Sheets("印刷元").Select Set データ範囲 = ActiveSheet.Range("A1").CurrentRegion 抽出列 = Array(22, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 5, 6, 7, 8, 9) 'For n = 0 To UBound(抽出列) 'データ範囲.Columns(抽出列(n)).Copy Sheets("temp").Range("B16").Offset(0, n) 'Next n End Sub この列の並びで001 田中商事、005 渡辺商事、300 鈴木商事といったそれぞれの明細を抽出し 同じフォルダーの中の別のBOOK「明細作成用.xlsx」に貼り付け順次印刷したいです。 「明細作成用.xlsx」はB16から明細が貼り付け可能でMAX6行です。7行目以降は2枚目3枚目になります。 よろしくお願い申し上げます。 （マクロン） 2018/04/03(火) 10:15 ---- お邪魔します。 こんな方法もありますということを知っておくと いつか役立つかも知れません。 Wordの差し込み印刷という機能を使います。 1）元ダータをID順番にソートします 2）元データに作業列を使い、IDの切り替わる行に印をつけます （if関数を使います） 3）元データに作業列を使い、印刷する行に印をつけます （Countif関数とIf関数を使います） 4）雛形は「明細作成用.xlsx」ではなくWordで作成します （フィールドコードを使います） 以上が可能であれば、マクロなしで実現できます。 3）は必須ではありませんんが、差し込み印刷の実行時にデータの絞り込みが簡単になります。 一番の課題は、フィールドコードを勉強する必要があることです。 （マナ） 2018/04/03(火) 13:00 ---- マナ様 ご回答ありがとうございます。 実は?@Wordに飛ばすバージョンと ?AExcelで頭紙（住所・企業名・あいさつ文）のバージョンは別に作成しております。 後は?B明細がExcelになっているので、この3パターン作成しております。 クライアントからの注文なのでWord・Excelのチョイス権が私にはありません。 差し込み印刷の件は参考になりましたが解決にはなりません。 また 別の方法でとか差し込み印刷とか○○の方がはやいとかいう回答は望んでおりません。 くどいようですが、選択権は私にはないので。 要件に沿った回答をお願いできればと思っております。 （マクロン） 2018/04/03(火) 13:17 ---- こんな感じでできると思います 1）作業シート作成 2）フィルターオプションで1）に抽出 3）明細に6行ずつ転記と印刷 4）これを指定のIDで繰り返す 5）1）のシートを削除 配列をつかわないので、却下かもしれませんが。 （マナ） 2018/04/03(火) 13:35 ---- マナさま ご指摘の構文は以下に作成しております。 Tempシート作成して転記するバージョンからステップアップして ダイレクトにと思い苦労しております。 小職ステップアップしより上級の構文を学びたいと思い こちらで勉強させたいただきたく投稿させていただきました。 Sub 明細() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lastRow As Long Dim r As Long Dim copyRow As Long Application.ScreenUpdating = False '高速化 Application.DisplayAlerts = False '確認メッセージ非表示 Set ws1 = Sheets("Temp") Set ws2 = Sheets("お客様用") lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 For r = 2 To lastRow Step 6 '2行目から最終行まで6行ずつ ws2.Range("B16:Q21").ClearContents 'B16:Q21値クリア copyRow = WorksheetFunction.Min(6, lastRow - r + 1) '最終行と注目行-1（すでに印刷が終わっている行）との差と6の小さい方 ws1.Range("M" & r).Resize(copyRow, 16).Copy ws2.Range("B16") 元dataシート → 明細作成補助シート → 明細印刷用シートの流れを ダイレクトに 元dataシート → 明細印刷用シート 作成の流れにしたく投稿させていただきました。 アイデアを募集しておりません。質問の意図と違う回答は望んでおりません。 どなたか質問の意図を理解した回答をお願いいたします。 （マクロン） 2018/04/03(火) 14:07 ---- Sub main() Dim wb As Workbook, t As Workbook, s As Worksheet, i As Long, c As Range, cc As Range, r As Range, d As Variant 抽出列 = Array(22, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 5, 6, 7, 8, 9) Set t = ThisWorkbook Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "¥明細作成用.xlsx") Set s = wb.Sheets(1) s.Cells.Clear For i = 0 To UBound(抽出列) s.Range("B16").Offset(, i).Value = t.Sheets("印刷元").Cells(1, 抽出列(i)).Value Next i Set r = s.Range("B17") For Each c In t.Sheets("Sheet2").Range("A:A").SpecialCells(xlCellTypeConstants) For Each cc In t.Sheets("印刷元").Range("A:A").SpecialCells(xlCellTypeConstants) If c = cc Then For Each d In 抽出列 r.Value = t.Sheets("印刷元").Cells(cc.Row, d) Set r = r.Offset(, 1) Next d If r.Row <= 21 Then Set r = r.Offset(1).EntireRow.Cells(2) Else s.PrintPreview s.Cells.Clear For i = 0 To UBound(抽出列) s.Range("B16").Offset(, i).Value = t.Sheets("印刷元").Cells(1, 抽出列(i)).Value Next i Set r = s.Range("B17") End If End If Next cc Next c wb.Close True End Sub （mm） 2018/04/03(火) 15:44 ---- 今朝見た情報だけで考えてみたものです。 なぜか、tmpを介さないと「If Join(tmp) <> "" Then」のようにできなかったので、ちょっと冗長になってしまいましたが、参考になれば・・・ Sub Sample() Dim i As Long Dim buf As String, 配列 As Variant, tmp As Variant Dim srcSH As Worksheet Dim dstSH As Worksheet Set dstSH = ThisWorkbook.Worksheets("シート1") Set srcSH = Workbooks("明細作成用.xlsx").Worksheets(1) 'シート2のA列に入力した文字で一次元配列を生成 With ThisWorkbook.Worksheets("シート2") If Range("A1").Value = "" Then Exit Sub For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row buf = buf & .Cells(i, "A").Value & "," Next i End With 配列 = Split(Left(buf, Len(buf) - 1), ",") '明細作成用ブックの1番目のシートの2〜最終行を順番にみていって 'コードが配列に含まれるものであれば、シート1にコピペ With srcSH For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row tmp = Filter(配列, .Cells(i, "A").Value) If Join(tmp) <> "" Then .Range(.Cells(i, "A"), .Cells(i, "A")).Copy _ dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1) End If Next i End With といいつつ、データ用意して動かしてみたわけではないので、上手く行かなかったら見なかったことにしてくださいm(_ _)m （もこな2） 2018/04/03(火) 20:34 ---- もこな2さん ありがとうございます。 イメージしていたコードそのものなのでこちらを是非使用させて いただきたい!と思っています。 ただ Set srcSH = Workbooks("明細作成用.xlsx").Worksheets(1) の箇所で「実行時エラー9 インデックスが有効範囲にありません」 と出てしまいます。 明細作成用.xlsxにはシートが全部で2枚ありますが 1枚目をSetしているので問題ないと思うのですが・・・ （マクロン） 2018/04/04(水) 11:07 ---- そうですね。。。 たとえばブックがxlsmだったりとか、そもそも、「明細作成用.xlsx」が開かれていないとか確認してみたほうが良いかもですね。 （もこな2） 2018/04/04(水) 12:18 ---- おしゃるとうり開かれてませんでした Set srcSH = Workbooks.Open("明細作成用.xlsx").Worksheets(1) Set srcSH = Workbooks.Open(ThisWorkbook.path & "¥明細作成用.xls").Sheets("Sheet1") Set srcSH = ThisWorkbook.path.Workbooks("明細作成用.xlsx").Sheets("Sheet1") とかいろいろ試してみましたが、ダメでした。1行でOpenしてとSetするには どのように書けばよろしいでしょうか? （マクロン） 2018/04/04(水) 14:37 ---- Set srcSH = Workbooks.Open(ThisWorkbook.path & "¥明細作成用.xls").Sheets("Sheet1") は掲示板に書き込む際にxlsxをxlsと書き間違えたのか、実際にxlsと書いたのか? 後者であればxlsxに書き直して試してはどうか? （ねむねむ） 2018/04/04(水) 14:53 ---- ねむねむさま Set srcSH = Workbooks.Open(ThisWorkbook.path & "¥明細作成用.xlsx").Sheets("Sheet1") と訂正してみましたがダメでした。 「実行時エラー9 インデックスが有効範囲にありません」 と出てしまいます。 （マクロン） 2018/04/04(水) 17:42 ---- （mm）さん 構文ありがとうございます。 試してみたのですが、 For Each c In t.Sheets("Sheet2").Range("A:A").SpecialCells(xlCellTypeConstants) の部分で 「実行時エラー9 インデックスが有効範囲にありません」 と出てしまいます。 tは開かれていますし、シートも2枚あります・・・・どうしてデバックになるのかわかりません。 （マクロン） 2018/04/04(水) 18:48 ---- ワークブックを（内部的に）取得することと、ワークシートをセットすることが同時にできるか私にはわからないので、わけて処理するように考えてみてはどうでしょうか。 たとえば↓みたいな感じではいかがでしょうか? とりあえず、今開いているブックを順番に見ていって「明細作成用.xls」があるなら、そのブックの1番目のシートを「srcSH」にセットして、開いているブックの中に「明細作成用.xls」がない（=srcSHがセットされてない。つまり、Nothing）であれば、「明細作成用.xls」を開いてから1番目のシートを「srcSH」にセットというプロセスを追加 ※ついでにコピー範囲をA〜A列 → A〜G列 に修正 Sub Sample() Dim i As Long Dim buf As String, 配列 As Variant, tmp As Variant Dim srcSH As Worksheet Dim dstSH As Worksheet Set dstSH = ThisWorkbook.Worksheets("シート1") '「明細作成用.xls」が開いているか確認して、開いていたら「srcSH」に1番目のシートをセット '開いていなかったら、開いてから「srcSH」に1番目のシートをセット Dim wb As Workbook For Each wb In Workbooks If wb.Name = "明細作成用.xlsx" Then Set srcSH = wb.Worksheets(1) End If Next wb If srcSH Is Nothing Then With Workbooks.Open(Filename:=ThisWorkbook.Path & "¥明細作成用.xlsx") Set srcSH = .Worksheets(1) End With End If 'シート2のA列に入力した文字で一次元配列を生成 With ThisWorkbook.Worksheets("シート2") If Range("A1").Value = "" Then Exit Sub For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row buf = buf & .Cells(i, "A").Value & "," Next i End With 配列 = Split(Left(buf, Len(buf) - 1), ",") '明細作成用ブックの1番目のシートの2〜最終行を順番にみていって 'コードが配列に含まれるものであれば、シート1にコピペ With srcSH For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row tmp = Filter(配列, .Cells(i, "A").Value) If Join(tmp) <> "" Then .Range(.Cells(i, "A"), .Cells(i, "G")).Copy _ dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1) End If Next i End With End Sub （もこな2） 2018/04/04(水) 19:17 ---- ども^^ 横入りすいません。 こういうのはフィルターオプションを使いましょうよ。 不要な列の削除や列の並び順の入れ替えなど （というか必要な項目だけを並べたい順番で書いておいたら） すごく少ないコードで書けますよ。 （準備は別途必要です。） （まっつわん） 2018/04/04(水) 19:43 ---- あっ それもそうですね。。 （もこな2） 2018/04/04(水) 19:52 ---- フィルタオプションは却下だそうです。 ＞また 別の方法でとか差し込み印刷とか○○の方がはやいとかいう回答は望んでおりません。 ＞アイデアを募集しておりません。質問の意図と違う回答は望んでおりません。 ＞どなたか質問の意図を理解した回答をお願いいたします。 （マナ） 2018/04/04(水) 20:03 ---- ふーむ そうなると 抑えるべき条件（外せない要件）はなんであるのか明確にしてから考えていったほうがよいですね。 たとえば、形はどうであれ配列つかってればokとか、For〜Nextステートメントを1回以上つかうとか。。。どのような要件を満たす必要があるのか、質問者さんからのレスがないと答えられないですね・・・・ （もこな2） 2018/04/04(水) 21:46 ---- 誤字訂正。 抑える → 押さえる ＞元dataシート → 明細作成補助シート → 明細印刷用シートの流れを ＞ダイレクトに ＞元dataシート → 明細印刷用シート 作成の流れにしたく投稿させていただきました。 ＞アイデアを募集しておりません。質問の意図と違う回答は望んでおりません。 ＞どなたか質問の意図を理解した回答をお願いいたします。 マナさんとまっつわんさんのフィルタオプションのアイデアから、オートフィルタで抽出して、そのままコピペでいいような気もしますが、それが「質問の意図」にあっているのか違っているのか、私にはわかりませんし、仕事を丸投げしておいて、その言い方はないだろうとおもうので、私は降りますね。 （もこな2） 2018/04/05(木) 08:09 ---- Sheet2というシート名がないからです。 （mm） 2018/04/05(木) 08:51 ---- あぁ、そうなんだ。 希望の回答が得られるまでの暇つぶしに、趣味の押し売りしてみますので、 遊びで試してみてください。 デスクトップに VBA練習というフォルダーを作り 練習元データ.xlsx と 練習マクロ.xlsm と2つのファイルを用意 練習元データ.xlsxの Sheet1（元データファイルには1つしかシートが無い前提。一番左でもOK)のイメージ ┌───┬────┬───┬───────┬──┬──┬──┐ │企業ID│企業名 │住所 │売り上げ日付け│品番│個数│金額│ ├───┼────┼───┼───────┼──┼──┼──┤ │001 │田中商事│東京 │ 20181002│G01 │ 2│ 300│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181002│G01 │ 2│ 300│ ├───┼────┼───┼───────┼──┼──┼──┤ │001 │田中商事│東京 │ 20181005│C01 │ 2│ 600│ ├───┼────┼───┼───────┼──┼──┼──┤ │005 │渡辺商事│大阪 │ 20181002│G01 │ 3│ 900│ ├───┼────┼───┼───────┼──┼──┼──┤ │300 │鈴木商事│名古屋│ 20181005│C01 │ 3│ 900│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181002│G01 │ 2│ 300│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181003│G02 │ 2│ 300│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181004│G03 │ 2│ 400│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181005│G04 │ 2│ 500│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181006│G05 │ 2│ 600│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181007│G06 │ 2│ 700│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181008│G07 │ 2│ 800│ ├───┼────┼───┼───────┼──┼──┼──┤ │002 │佐藤商事│東京 │ 20181009│G08 │ 2│ 900│ └───┴────┴───┴───────┴──┴──┴──┘ 次に 練習マクロ.xlsmの 「ID入力用」シートのイメージ ┌───┐ │企業ID│ ├───┤ │002 │ ├───┤ │300 │ ├───┤ │ │ ├───┤ │ │ ├───┤ │ │ └───┘ 「作業用」シートのイメージ （敢えて列の順番を入れ替えてます。こんなことが簡単に出来ますよという紹介） ┌───┬──┬──┬──┬───────┐ │企業名│品番│個数│金額│売り上げ日付け│ └───┴──┴──┴──┴───────┘ 「明細書印刷テンプレート」シートのイメージ 様 ────────── ┌──┬──┬──┬───────┐ │品番│個数│金額│売り上げ日付け│ ├──┼──┼──┼───────┤ │ │ │ │ │ ├──┼──┼──┼───────┤ │ │ │ │ │ ├──┼──┼──┼───────┤ │ │ │ │ │ ├──┼──┼──┼───────┤ │ │ │ │ │ ├──┼──┼──┼───────┤ │ │ │ │ │ ├──┼──┼──┼───────┤ │ │ │ │ │ └──┴──┴──┴───────┘ と用意します。 で、コードはこんな感じ。 Option Explicit Sub メイン() Dim wbkData As Workbook '元のデータブック Dim v As Variant '各ID Dim vID As Variant '抽出するIDの仮置場 Dim rngData As Range '元データのセル範囲 Dim rngCriteria As Range '抽出条件のセル範囲 Dim rngCopyTo As Range '抽出結果のセル範囲 Dim rngPrinting As Range '明細書のデータ書き込み範囲 Dim ixRow As Long '行番号ループカウンタ Dim ixMax As Long '明細書に書き込める行数 'セル範囲の定義 With ThisWorkbook Set rngCriteria = .Sheets("ID入力用").Range("A1:A2") Set rngCopyTo = .Sheets("作業用").Range("A1:E1") Set rngPrinting = .Sheets("明細印刷テンプレート").Range("A4:D9") ixMax = rngPrinting.Rows.Count End With '元データを開く Set wbkData = Workbooks.Open(Filename:="C:¥Users¥hi¥Desktop¥マクロ練習¥練習元データ.xlsx") Set rngData = wbkData.Sheets(1).Range("A1").CurrentRegion '入力IDの取得（入力が無ければプログラムを抜ける） With rngCriteria.CurrentRegion If .Count < 2 Then Exit Sub vID = WorksheetFunction.Transpose( _ Intersect(.Cells, .Offset(1))) End With '入力したID毎に繰り返し For Each v In vID 'データ抽出 rngCriteria(2).Value = v rngData.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=rngCriteria, _ CopyToRange:=rngCopyTo 'テンプレートへデータを転記して印刷 With rngCopyTo.CurrentRegion If .Rows.Count > 1 Then For ixRow = 2 To .Rows.Count Step ixMax .Rows(ixRow).Resize(ixMax, .Columns.Count - 1).Offset(, 1).Copy rngPrinting.PasteSpecial xlPasteValues rngPrinting(-2, 1).Value = .Cells(2, 1).Value rngPrinting.Worksheet.PrintPreview 'rngPrinting.Worksheet.PrintOut '本番で印刷するときはこっち Next End If End With Next '入力を元に戻す rngCriteria.Offset(1).Resize(UBound(vID)).Value = WorksheetFunction.Transpose(vID) '元のファイルを閉じる wbkData.Close False Set wbkData = Nothing End Sub この辺を叩き台にして作っていってみてはいかがでしょうか? 余分な情報は無しで、今やっていることを少しずつステップアップしていきたいという 気持ちはわかります。 ただ、セルを1個1個ループするのは時間が掛かりますし、 何よりセルの位置関係を上手く表現できているかデバッグするのが大変だと思います。 （ということは回答者も大変） エクセルの機能を有効的に利用することをお勧めします。 まぁ、根を詰めずに息を抜いて、気分転換にどうぞ。 （まっつわん） 2018/04/05(木) 10:30 ---- やりたいことはこういう事かな。。。 列番が順番じゃない時は無理にループさせるのは好みで無いので、 つらつら書き連ねてます。 （ループだとあとで読んで、どの列がこっちの表のどの列と対応しているか分かり難くないですか?） あと、先にセル範囲を定義（あるいは取得?）しちゃうのが自分的にわかりやすいので、 こういう書き方です。なので、対象のセル範囲がどこどこにある、と明示されていると、 コードが書きやすいです。 「どのブックのどのシートのA1から続く途中に空白のない空白で区切られたセル範囲」 とか あぁ、あと印刷用のひながたが呼んだ限り6行じゃないっぽいのかなぁ? 結合セルを使っている場合は、結合セルを使っているというのを言っておかないと、 普通そういうのは考慮しないので、回答が不具合が出る恐れがあるコードになることがありますので、 もし結合セルがあるならあると明記しましょう。 あぁ、表中に空白行や空白列がある場合も明記していただけると、ありがたいです。 Option Explicit Sub test001() Dim rngData As Range Dim rngList As Range Dim rngPrinting As Range Dim rngID As Range Dim c As Range Dim ixRow As Long Set rngData = Workbooks("明細作成用.xlsx").Sheets(1).Range("A1").CurrentRegion Set rngList = ThisWorkbook.Sheets("Sheet2").Range("A1").CurrentRegion Set rngPrinting = ThisWorkbook.Sheets("お客様用").Range("B16:Q21") '入力したIDを順に見て行く For Each rngID In rngList.Cells 'データを順に見て行く For Each c In rngData.Columns("A").Cells 'Keyと同じIDが出てきたら If rngID.Text = c.Text Then '書き込む行番号を用意 ixRow = ixRow + 1 'データを転記 With rngPrinting.Rows(ixRow) .Range("A1").Value = c(1, 22).Value .Range("B1").Value = c(1, 24).Value .Range("C1").Value = c(1, 25).Value .Range("D1").Value = c(1, 26).Value .Range("E1").Value = c(1, 27).Value .Range("F1").Value = c(1, 28).Value .Range("G1").Value = c(1, 29).Value .Range("H1").Value = c(1, 30).Value .Range("I1").Value = c(1, 31).Value .Range("J1").Value = c(1, 32).Value .Range("K1").Value = c(1, 33).Value .Range("L1").Value = c(1, 5).Value .Range("M1").Value = c(1, 6).Value .Range("N1").Value = c(1, 7).Value .Range("O1").Value = c(1, 8).Value .Range("P1").Value = c(1, 9).Value End With 'もしデータが6つ溜まった、または元データを最後まで見たなら If ixRow = 6 Or c.Row = rngData.Rows.Count Then '印刷 rngPrinting.Worksheet.PrintPreview '初期化 rngPrinting.ClearContents ixRow = 0 End If End If Next Next End Sub このままでは処理に時間が掛かるかもしれませんね。。。。 まぁ、その時はまた高速化を考えましょう。。。 （まっつわん） 2018/04/05(木) 12:20 ---- 皆様 多くの回答ありがとうございました。また失言がありましたことをおわび申し上げます。 多くの回答をいただいたのですが、意図する結果がうまく得られたものがなかったため まずは小職のつたないスキルで下記のコードを作成しました Sub 途中() Dim データ範囲 As Range Dim 抽出列 As Variant Dim myData As String Dim n As Long Dim mypath2 As Workbook Dim ws1 As Worksheet Set ws1 = Sheets("印刷元") Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx") mypath2.Sheets(1).Range("B16:Q21").ClearContents '値のみクリア Set データ範囲 = ws1.Range("A1").CurrentRegion Set データ範囲 = Application.Intersect(データ範囲, データ範囲.Offset(1)) 'タイトル行を除く 抽出列 = Array(1, 2, 4) For n = 0 To UBound(抽出列) データ範囲.Columns(抽出列(n)).Copy mypath2.Sheets(1).Range("B16").Offset(0, n) Next n mypath2.Sheets(1).Range("B16:Q21").Borders.LineStyle = xlContinuous '罫線を引く mypath2.PrintPreview MsgBox "処理完了しました。" End Sub 以上の構文は正常作動することを確認しました。 次にフィルターで該当のIDに対しての処理というところを追加しようと思ったのですが うまくいきません。この構文のどこを修正すればよいか教えていただけませんでしょうか? Sub 途中2() Dim データ範囲 As Range Dim 抽出列 As Variant Dim myData As String Dim n As Long, i As Long, myRow As Long Dim mypath2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet Dim myNo As String Set ws1 = ThisWorkbook.Sheets(1) Set ws2 = ThisWorkbook.Sheets(2) Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx") For i = 2 To ws2.Range("A" & Rows.Count).End(xlUp).Row 'A列2行目〜最終行まで順番に処理 mypath2.Sheets(1).Range("B16:Q21").ClearContents '値のみクリア myNo = Range("A" & i).Value ws1.Range("A1").AutoFilter Field:=1, Criteria1:=myNo 'オートフィルタでデータを抽出する Set データ範囲 = ws1.Range("A1").CurrentRegion Set データ範囲 = Application.Intersect(データ範囲, データ範囲.Offset(1)) 'タイトル行を除く 抽出列 = Array(1, 2, 4) For n = 0 To UBound(抽出列) データ範囲.Columns(抽出列(n)).Copy mypath2.Sheets(1).Range("B16").Offset(0, n) Next n mypath2.Sheets(1).Range("B16:Q21").Borders.LineStyle = xlContinuous '罫線を引く ws1.Range("A1").AutoFilter 'オートフィルタを解除 mypath2.PrintOut Next i mypath2.Close MsgBox "処理完了しました。" End Sub 試しに2IDについて稼働してみたところ、同じものが4枚印刷されてしまいます よろしくお願い申し上げます。 （マクロン） 2018/04/09(月) 09:51 ---- >この構文のどこを修正すればよいか教えていただけませんでしょうか? んとですね。 最終的に操作するのはセル範囲だと思うんですよね。 ということはRange型で変数を定義しセル範囲を変数に保持しておくのがいいと思います。 次に、 Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx") ↑これは印刷する雛型ファイルですか? 名前的にmypathだと何を意図しているかさっぱりわかりません。 名前も意図に沿った名前にした方がいいと思います。 英語で表現しにくかったら日本語でもぜんぜんいいと思います。 そして、セル範囲は、必ずどのブックのどのシートのセル範囲なのかを明示してください。 それを怠ると、状況により結果が変わる可能性があります。 一部忘れている（省略している?）箇所が見受けられます。 とりあえずそれをちゃんと意図通りにブック、シートの記述を追加してみたらいかがでしょうか。 僕ならこう書くかなというサンプルです。 動作確認はしてません。エラーで止まるかも知れませんが、 読んで作業の流れを確認してみてください。 Sub サンプル() Dim wbkデータ As Workbook 'データベースとなるブック（別のブック） Dim rngデータ As Range '元のデータ Dim rng印刷データ As Range '印刷雛型セル範囲（自マクロブック) Dim rngID入力欄 As Range '印刷したいIDを入力したセル範囲 Dim rngID As Range '各IDのセル '前提条件として各セル範囲を定義 Set wbkデータ = Workbooks.Open(ThisWorkbook.Path & "¥base.xlsx") Set rngデータ = wbkデータ.Sheets(1).Range("A1").CurrentRegion Set rng印刷データ = ThisWorkbook.Sheets(1).Range("B16:Q21") With ThisWorkbook.Sheets(2).Range("A1").CurrentRegion Set rngID入力欄 = Intersect(.Cells, .Offset(1)) End With '各ID毎に繰り返し For Each rngID In rngID入力欄 '印刷データ欄クリア rng印刷データ.ClearContents 'IDのデータを抽出して印刷データ欄にコピペ With rngデータ .AutoFilter Field:=1, Criteria1:=rngID.Value Intersect(.Cells, .Offset(1), .Worksheet.Range("A,B,D")).Copy rng印刷データ(1) End With '印刷雛型シートを印刷プレビュー（動作確認テスト用） rng印刷データ.Worksheet.PrintPreview Next 'データベースは保存せずに閉じる wbkデータ.Close False End Sub （まっつわん） 2018/04/09(月) 12:24 ---- 気に入るかどうかは知らないけど、インデントがなくて見辛かったので私の趣味全開で「途中」の方を整理するとこんな感じかな。（実データないので、コンパイルエラーにならないかくらいしか見てないけど） Sub 途中() Dim tmp As Object Dim buf As Variant Dim データ範囲 As Range Dim n As Long Dim mypath2 As Workbook '「データ範囲」のセット With Sheets("印刷元").Range("A1").CurrentRegion If .Rows.Count <= 1 Then Exit Sub '1未満はないだろうが一応 Set データ範囲 = Application.Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)) End With '「mypath2」のセット For Each tmp In Workbooks If tmp.Name = "¥base2.xlsx" Then Set mypath2 = tmp Next tmp If mypath2 Is Nothing Then mypath2 = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") '処理 With mypath2.Sheets(1).Range("B16:Q21") .ClearContents '値のみクリア For Each buf In Array(1, 2, 4) データ範囲.Columns(buf).Copy .Cells(1).Offset(0, n) n = n + 1 Next buf .Borders.LineStyle = xlContinuous '罫線を引く End With '印刷プレビュー mypath2.PrintPreview '後処理 Set mypath2 = Nothing MsgBox "処理完了しました。" End Sub 想定外の動きをしているなら一度、「途中2」について、コードを（自分が見やすいように）整理した上でステップ実行で思うとおり動いているかみたらいいんじゃないですか? （もこな2） 2018/04/09(月) 12:42 ---- 皆さま お忙しい中ご解答ありがとうございます。 今回頂いた回答は今からRUNさせていただきます。 それと別にお昼にまっつわんさんの以前に頂いた構文をすこし変更して見ましたが こちらはデバックになってしまうので修正方法を教えていただけませんでしょうか? Sub 途中3() Dim ws1 As Range Dim ws2 As Range Dim mypath2 As Range Dim rngID As Range Dim c As Range Dim ixRow As Long Set ws1 = ThisWorkbook.Sheets(1).Range("A1").CurrentRegion Set ws2 = ThisWorkbook.Sheets(2).Range("A1").CurrentRegion Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx").Range("B16:Q21") For Each rngID In ws2.Cells '入力したIDを順に見て行く For Each c In ws1.Columns("A").Cells 'データを順に見て行く If rngID.Text = c.Text Then 'Keyと同じIDが出てきたら ixRow = ixRow + 1 '書き込む行番号を用意 With mypath2.Rows(ixRow) 'データを転記 .Range("A1").Value = c(1, 1).Value .Range("B1").Value = c(1, 2).Value .Range("C1").Value = c(1, 4).Value End With 'もしデータが6つ溜まった、または元データを最後まで見たなら If ixRow = 6 Or c.Row = ws1.Rows.Count Then '印刷 mypath2.Worksheet.PrintPreview '初期化 mypath2.ClearContents ixRow = 0 End If End If Next Next End Sub set my path2のところでエラー438 オブジェクトはこのプロパティ又はメソッドをサポートしていませんとでてしまいます 何処を修正すればよろしいでしょうか? （マクロン） 2018/04/09(月) 13:26 ---- ＞何処を修正すればよろしいでしょうか? どのシートかの記述がないですよ? （まっつわん） 2018/04/09(月) 15:16 ---- まっつわんさん ありがとうございます。下記修正してみました。 Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx").Sheets(1).Range("B16:Q21") ただws1のタイトル行がmypath2のB16の行に入ってしまいます。 また試しに2ID記入してRUNさせてみましたが、1個目のIDにだけ実行され印刷物は1枚のみでした （マクロン） 2018/04/09(月) 15:31 ---- お節介コメント第?弾 何回いってもインデントつけませんけど、ご自分でみて見づらくないんでしょうか? ご自身で見づらいと思うなら、回答者も同じなので改善されたほうがよいと思います。 信条ならしょうがないですけど、おそらく回答は減ってしまうと思います。 変数名もほかの回答者さんから指摘がありますが、 「ws1」←シートとおもいきや、セル範囲 「ws2」←シートとおもいきや、セル範囲 「mypath2」←パス（文字列）と思いきや、セル範囲 「c」←カウンタ（整数型）と思いきや、セル範囲（Cellsの頭文字?） など、読もうとおもっても???ってなりますので、可能であれば変数名も再考した方がよいのかも。 もちろん、上記のことについて質問者さんに決定権があるのか知りませんし、 意図に沿ってるのかもわかりませんので、変えろという意味ではなく、 あくまで個人的にそう思うってことです。 ちなみに、下記は、そのままインデントを入れただけです。 これが正解というわけではありませんが、インデント入れの参考にしてください。 Sub 途中3() Dim ws1 As Range, ws2 As Range Dim mypath2 As Range Dim rngID As Range Dim c As Range Dim ixRow As Long Set ws1 = ThisWorkbook.Sheets(1).Range("A1").CurrentRegion Set ws2 = ThisWorkbook.Sheets(2).Range("A1").CurrentRegion Set mypath2 = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx").Range("B16:Q21") For Each rngID In ws2.Cells '入力したIDを順に見て行く For Each c In ws1.Columns("A").Cells 'データを順に見て行く If rngID.Text = c.Text Then 'Keyと同じIDが出てきたら ixRow = ixRow + 1 '書き込む行番号を用意 With mypath2.Rows(ixRow) 'データを転記 .Range("A1").Value = c(1, 1).Value .Range("B1").Value = c(1, 2).Value .Range("C1").Value = c(1, 4).Value End With 'もしデータが6つ溜まった、または元データを最後まで見たなら If ixRow = 6 Or c.Row = ws1.Rows.Count Then '印刷 mypath2.Worksheet.PrintPreview '初期化 mypath2.ClearContents ixRow = 0 End If End If Next Next End Sub また、ご質問については、私のスキルだと以下で問題ないのか解らないですが、少なくとも「base2.xlsx」が開いてたらエラーで止まるんじゃないかとおもいます。 ブックが開いてるかどうかチェックする方法は、「2018/04/09(月) 12:42」に一例を出してますので、興味があれば読んで下さい。（他にも方法はあります） そして、絶対開いてないとの保証がある場合でも、前述のとおり私のスキルだと、ブックを開いて その戻り値を使って、ブックのセル範囲を変数にセットすることができるか解らないので 私ならこんな感じにします。 Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx").Sheets(1).Range("B16:Q21") ↓ With Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") Set mypath2 = Sheets(1).Range("B16:Q21") End With （もこな2） 2018/04/09(月) 19:40 ---- 誤字等に気が付いたので訂正します。 ●2018/04/09(月) 12:42のコード中 If mypath2 Is Nothing Then mypath2 = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") ↓ If mypath2 Is Nothing Then Set mypath2 = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") また、「2018/04/09(月) 19:40」のコメントについてテストしてみたところ、「Workbooks.Open」の戻り値とその配下のシートやセルの操作（セット）を1行で記述することも問題ないし、「base2.xlsx」を開いてから一度も変更していないのであれば、そのブックを開きなおすだけなのでエラーにならないですね。失礼しました。 （もこな2） 2018/04/09(月) 22:16 ---- もこな2さま インデントの件何度も申し訳ありませんでした。 以後意識してみます! 変数名も了解しました! なんでもいいものかと・・・ さて皆様の回答を参考に、下記コードができあがり、 正常にRUNすることを確認しました。 Sub ExcelからExcelへ差し込み印刷() Application.ScreenUpdating = False '高速化 Application.DisplayAlerts = False '確認メッセージ非表示 Dim ws1 As Worksheet, ws2 As Worksheet Dim データ範囲 As Range Dim myNos, myNo Dim myBook As Workbook Const 抽出列 As String = "A:B,D:D" Set ws1 = ThisWorkbook.Sheets(1) Set ws2 = ThisWorkbook.Sheets(2) Set myBook = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx") With ws2 myNos = Application.Transpose(.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))) 'A列2行目〜最終行の値 End With Application.ScreenUpdating = False For Each myNo In myNos With ws1.Range("A1").CurrentRegion .AutoFilter Field:=1, Criteria1:=myNo 'オートフィルタでデータを抽出する Set データ範囲 = Intersect( _ .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Range(抽出列)) .AutoFilter End With With myBook.Sheets(1).Range("B16:Q21") .ClearContents '値のみクリア データ範囲.Copy .Cells(1) .Borders.LineStyle = xlContinuous '罫線を引く End With myPath2.PrintOut Next myNo myPath2.Close Application.ScreenUpdating = True MsgBox "処理完了しました。" End Sub 後はこれを6行で印刷。データが終わるまで繰返しにすれば完成なのですが。。。。 （マクロン） 2018/04/10(火) 15:57 ---- もこな2さん＞＞ ＞変数にセットすることができるか解らないので Set mypath2 = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx").Sheets(1).Range("B16:Q21") 〜〜〜ヘルプより抜粋〜〜〜 Excel 開発者用リファレンス Workbooks.Open メソッド すべて表示すべて表示 すべて非表示すべて非表示 ブックを開きます。 途中略 戻り値 開いているブックを表す Workbook オブジェクト。 〜〜〜抜粋終わり〜〜〜 オブジェクトが返ってきているので、 Workbooks(1)と同じでしょう、 同様にSheetsプロパティが返すSheetオブジェクトのRangeプロパティが返すRangeオブジェクト となるので、最終的に返ってくるのはRangeオブジェクトです。 1行で書いてもいいですが、 開いたブックは閉じたいと思うので、 workbook型の変数を用意しておいて代入しておけば閉じるときに便利だと思いますが。。。 マクロンさん＞＞ なんで画面更新の無効化ややメッセージの無効化をデバッグ段階でするのですか? こういうのは最後に付け足しましょう。 デバッグの作業を困難にするだけです。 ＞後はこれを6行で印刷。データが終わるまで繰返しにすれば完成なのですが。。。。 作業用のシートに1回抽出したデータを吐き出しておいて、 それから6行づつ印刷してはどうですか? （まっつわん） 2018/04/10(火) 18:18 ---- まっつわんさん tempに一度抽出したものが下記のコードで以前つくったものです （インデント・変数等 すみません） Sub 明細作成() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lastRow As Long Dim r As Long Dim copyRow As Long Set ws1 = Sheets("Temp") Set ws2 = Sheets("ああああ") lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 For r = 2 To lastRow Step 6 '2行目から最終行まで6行ずつ ws2.Range("B16:Q21").ClearContents 'B16:Q21値クリア copyRow = WorksheetFunction.Min(6, lastRow - r + 1) '最終行と注目行-1（すでに印刷が終わっている行）との差と6の小さい方 ws1.Range("M" & r).Resize(copyRow, 16).Copy ws2.Range("B16") ws2.Range("B16:Q21").Borders.LineStyle = xlContinuous '罫線を引く Next End Sub 元dataシート → 明細作成補助シート → 明細印刷用シートの流れを ダイレクトに 元dataシート → 明細印刷用シート 作成の流れにしたかったのですが、やはり無理ですかね? （マクロン） 2018/04/10(火) 18:29 ---- Sub test() Application.ScreenUpdating = False '高速化 Application.DisplayAlerts = False '確認メッセージ非表示 Dim ws1 As Worksheet, ws2 As Worksheet Dim データ範囲 As Range Dim myNos, myNo Dim myBook As Workbook Dim r As Long Dim lastRow As Long Const 抽出列 As String = "A:B,D:D" Set ws1 = ThisWorkbook.Sheets(1) Set ws2 = ThisWorkbook.Sheets(2) Set myBook = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx") With ws2 myNos = Application.Transpose(.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))) 'A列2行目〜最終行の値 End With For Each myNo In myNos With ws1.Range("A1").CurrentRegion .AutoFilter Field:=1, Criteria1:=myNo 'オートフィルタでデータを抽出する Set データ範囲 = Intersect( _ .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Range(抽出列)) .AutoFilter lastRow = データ範囲.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 End With For r = 2 To lastRow Step 6 '2行目から最終行まで6行ずつ With myBook.Sheets(1).Range("B16:Q21") .ClearContents '値のみクリア copyRow = WorksheetFunction.Min(6, lastRow - r + 1) '最終行と注目行-1（すでに印刷が終わっている行）との差と6の小さい方 データ範囲.Range("M" & r).Resize(copyRow, 16).Copy myBook.Range("B16") .Borders.LineStyle = xlContinuous '罫線を引く End With myBook.PrintOut Next r Next myNo myBook.Close MsgBox "処理完了しました。" Application.ScreenUpdating = True End Sub 取り急ぎ上記のコード作ってみたのですが lastRow = データ範囲.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 のところで実行時エラー1004 アプリケーション定義または、オブジェクト定義のエラーです。 とでてしまいます。 これは無理ですかね? （マクロン） 2018/04/10(火) 18:46 ---- ＞ ダイレクトに ＞元dataシート → 明細印刷用シート 作成の流れにしたかったのですが、やはり無理ですかね? 無理じゃないですけど、敢えて難しくする必要はないかと思いますが? ＞データ範囲.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 ↑これデータ最終行じゃないです。 しかも、データ範囲に入っているセル範囲は飛び飛びのはずなので、 簡単に6行毎というわけにはいきません。 コピペすると飛び飛びが無くなるので、 6行毎というのが結構簡単になります。 myBook.Range("B16") ↑シートの修飾を忘れています 基本的にセル範囲を操作するのだから、 Rangeオブジェクト（≒セル範囲その物）で変数を定義して、 代入しておけばこんな間違いは減るかなとは思います。 （まっつわん） 2018/04/10(火) 19:26 ---- ＞1行で書いてもいいですが、開いたブックは閉じたいと思うので、 ＞workbook型の変数を用意しておいて代入しておけば閉じるときに便利だと思いますが。。。 なるほど。閉じることまでは考えてなかったです。 であれば、同じことではありますが「変数を用意」に変えて先のとおり、Withステートメントの使用を推しておきます。 ＞後はこれを6行で印刷。データが終わるまで繰返しにすれば完成なのですが。。。。 余白等を調整して6行しか1ページに収まらないようにしてからオートフィルタを設定したシートを 全ページ印刷したらどうでしょうか。 また、ScreenUpdating 、DisplayAlerts については、まっつわんさんにおなじです。 オマケの部分ですから、ちゃんと動くようになってから自分のすきな時に追加すればいいだけにおもいます。 加えて、 ScreenUpdatingを無効にしている部分が2箇所あるので、かたっぽ要らないですよね。 逆に、DisplayAlertsを戻してないようにおもいますがいいんですか? （もこな2） 2018/04/10(火) 19:44 ---- Sub test() 'Dim ws1 As Worksheet, ws2 As Worksheet 'Dim データ範囲 As Range Dim rngデータ As Range Dim rng印刷データ As Range Dim rng作業用 As Range 'Dim myNos, myNo Dim rngNo As Range Dim c As Range 'Dim myBook As Workbook Dim wbkPrint As Workbook 'Dim r As Range Dim i As Long 'Const 抽出列 As String = "A:B,D:D" ' With ThisWorkbook 'Set ws1 = ThisWorkbook.Sheets(1) Set rngデータ = .Sheets(1).Range("A1").CurrentRegion 'Set ws2 = ThisWorkbook.Sheets(2) With .Sheets(2) Set rngNo = Application.Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp)) End With Set rng作業用 = .Sheets(3).Range("A1") End With 'Set myBook = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") Set wbkPrint = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") Set rng印刷データ = wbkData.Sheets(1).Range("B16:Q21") 'With ws2 'myNos = Application.Transpose(.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))) 'A列2行目〜最終行の値 'End With rng印刷データ.ClearComments rng作業用.ClearContents 'For Each myNo In myNos For Each c In rngNo 'With ws1.Range("A1").CurrentRegion With rngデータ '.AutoFilter Field:=1, Criteria1:=myNo 'オートフィルタでデータを抽出する .AutoFilter Field:=1, Criteria1:=c.Value 'Set データ範囲 = Intersect( _ '.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Range(抽出列)) Intersect(.Cells, .Offset(1), .Worksheet.Range("A:B,D:D")).Copy rng作業用 '.AutoFilter 'End With End With With rng作業用.CurrentRegion For i = 1 To .Rows.Count Step 6 ' 'myBook.Sheets(1).Range("B16:Q21").ClearContents 'For Each r In データ範囲.Rows 'i = i + 1 't.Range("M1").Resize(, 16).Copy .Rows(i).Resize(6).Copy rng印刷データ.PasteSpecial Paste:=xlPasteValues 'データ範囲.Range("M" & r).Resize(copyRow, 16).Copy myBook.Range("B16") '.Borders.LineStyle = xlContinuous '罫線を引く 'End With 'myBook.PrintOut .Worksheet.PrintPreview 'Loop Next End With 'Next myNo Next 'myBook.Close wbkPrint.Close False End Sub 余計分かり難いかな。。。 ま、書きたいように書いてくれればいいけど。。。 （まっつわん） 2018/04/10(火) 19:59 ---- 結局、作業用シートを使う案になりましたか? ならば、最初に提案したフィルタオプションを使うと 抽出列の指定も簡単です。 Option Explicit Sub test() Dim 雛形シート As Worksheet Dim 転記項目 As Range Dim wbT As Workbook Dim rngE As Range Dim rngC As Range Dim 全データ As Range Dim i As Long Set 雛形シート = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx").Worksheets("明細") Set 転記項目 = 雛形シート.Range("B15:Q15") Set wbT = Workbooks.Add 転記項目.Copy wbT.Sheets(1).Range("A1") Set rngE = wbT.Sheets(1).Range("A1").CurrentRegion Set rngC = rngE(1).Offset(, rngE.Count + 2) rngC.Value = 転記項目(1).Value ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion.Copy rngC.Offset(1) Set 全データ = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion Do While rngC.Offset(1).Value <> "" 全データ.AdvancedFilter xlFilterCopy, rngC.Resize(2), rngE For i = 2 To rngE.End(xlDown).Row Step 6 転記項目.Offset(1).Resize(6).Value = rngE.Rows(i).Resize(6).Value 雛形シート.PrintOut Next rngC.Offset(1).Delete xlShiftUp Loop wbT.Close False 雛形シート.Parent.Close False End Sub （マナ） 2018/04/10(火) 22:33 ---- まっつわんさま・もこな2さま・マナさま mana ありがとうございます。いろいろ勉強になりました。 ただ（まっつわん） 2018/04/10(火) 19:59 （マナ） 2018/04/10(火) 22:33 の両方とも正常作動しなくて 残念です。 （マクロン） 2018/04/11(水) 09:52 ---- 皆様のおかげで、下記の構文でデバックにはならずRUNはするようになりました。 Sub test() Application.ScreenUpdating = False '高速化 Application.DisplayAlerts = False '確認メッセージ非表示 Dim ws1 As Worksheet, ws2 As Worksheet Dim データ範囲 As Range Dim myNos, myNo Dim myBook As Workbook Dim r As Long Dim lastRow As Long Const 抽出列 As String = "A:B,D:D" Set ws1 = ThisWorkbook.Sheets(1) Set ws2 = ThisWorkbook.Sheets(2) Set myBook = Workbooks.Open(ThisWorkbook.path & "¥base2.xlsx") With ws2 myNos = Application.Transpose(.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))) 'A列2行目〜最終行の値 End With For Each myNo In myNos With ws1.Range("A1").CurrentRegion .AutoFilter Field:=1, Criteria1:=myNo 'オートフィルタでデータを抽出する Set データ範囲 = Intersect( _ .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Range(抽出列)) .AutoFilter lastRow = .Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 End With For r = 2 To lastRow Step 6 '2行目から最終行まで6行ずつ With myBook.Sheets(1).Range("B16:Q21") .ClearContents '値のみクリア copyRow = WorksheetFunction.Min(6, lastRow - r + 1) '最終行と注目行-1（すでに印刷が終わっている行）との差と6の小さい方 データ範囲.Range("M" & r).Resize(copyRow, 16).Copy myBook.Sheets(1).Range("B16") .Borders.LineStyle = xlContinuous '罫線を引く End With myBook.PrintOut Next r Next myNo myBook.Close MsgBox "処理完了しました。" Application.ScreenUpdating = True End Sub まっつわんさんのおしゃる通り 「データ範囲に入っているセル範囲は飛び飛びのはずなので」 データに空白行がふくまれているようで正常印刷にはいたっていません。 これを Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible) '可視のみ選択 とか Dim i As Integer if Cells(i,2).EntireRow.Hidden = False Then '非表示でなければ ここら辺を使用して空白を除いて処理できませんでしょうか? よろしくお願い申し上げます。 （マクロン） 2018/04/11(水) 11:29 ---- >ここら辺を使用して空白を除いて処理できませんでしょうか? なので、コピペすると、空白を除去できます。 またコピペするならマナさんがされているようにフィルターオプションの機能に コピペも付いているので、 いろいろ記述する必要が無くなります。 操作に不要な作業用のシートはあとで非表示にでもして、 ユーザーが誤って触れないようにしておけばよいでしょう。 まぁ、そのままでも出来なくないけど、コードが複雑になるだけかと。。。 1年後メンテナンスの必要が出てきた場合、あるいは機能追加の要望が出てきたときに、 自分で解読できる自信がありますか? こういうのも考慮して、マクロを作りましょう^^ （まっつわん） 2018/04/11(水) 12:05 ---- 頭の体操に。。。 動作確認してませんけど、 こんな感じで数数えればいいんじゃないかと思いますが、 この手の作業は、 普段作業用シートに、フィルターオプションで抜き出してから やってるので、自信50% Sub test() Dim ws1 As Worksheet, ws2 As Worksheet Dim データ範囲 As Range Dim myNos, myNo Dim myBook As Workbook Dim rngPrint As Range Dim r As Range Dim lastRow As Long Dim ixRow As Long Const 抽出列 As String = "A:B,D:D" ' Application.ScreenUpdating = False '高速化 ' Application.DisplayAlerts = False '確認メッセージ非表示 Set ws1 = ThisWorkbook.Sheets(1) Set ws2 = ThisWorkbook.Sheets(2) Set myBook = Workbooks.Open(ThisWorkbook.Path & "¥base2.xlsx") With ws2 myNos = Application.Transpose(.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))) 'A列2行目〜最終行の値 End With Set rngPrint = myBook.Sheets(1).Range("B16:Q21") For Each myNo In myNos With ws1.Range("A1").CurrentRegion .AutoFilter Field:=1, Criteria1:=myNo 'オートフィルタでデータを抽出する Set データ範囲 = Nothing If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then Set データ範囲 = Intersect(.SpecialCells(xlCellTypeVisible), .Offset(1), .Worksheet.Range(抽出列)) End If .AutoFilter '6行毎に貼りつけ For Each r In データ範囲.Rows ixRow = ixRow + 1 r.Range(M1).Resize(, 16).Copy rngPrint.Rows(ixRow) If ixRow = 6 _ Or Intersect(データ範囲, r.Next) Is Nothing Then With rngPrint .Worksheet.PrintPreview .ClearContents ixRow = 0 End With End If Next End With Next myNo myBook.Close ' MsgBox "処理完了しました。" ' Application.ScreenUpdating = True End Sub （まっつわん） 2018/04/11(水) 14:48 ---- まっつわんさん コードありがとうございました。下記のところでエラーになってしまうのですが 余裕のあるときに修正してみたいとおもってます。 r.Range(M1).Resize(, 16).Copy rngPrint.Rows(ixRow) ちなみに「データ範囲に入っているセル範囲は飛び飛びのはずなので、」 ここら辺のことを今後の勉強の為に、初心者の私に理解できるように ご説明もしくは参考URLとかいただけませんでしょうか? よろしくお願い申し上げます。 （マクロン） 2018/04/12(木) 09:31... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201804/20180402234321.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97049 documents and 608241 words.
訪問者：