[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『印刷ツール』（マクロン）
企業情報や売り上げのデータが入っているシート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枚・３枚と枚数が増えます。
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」は何のための数字なのかわからないのでそれも補足説明していただかないと、Ｅｘｃｅｌ君にも回答者にも状況が伝わらないと思います。
（もこな２） 2018/04/03(火) 00:15
例
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の差し込み印刷という機能を使います。
１）元ダータをID順番にソートします
２）元データに作業列を使い、IDの切り替わる行に印をつけます
（if関数を使います）
３）元データに作業列を使い、印刷する行に印をつけます
（Countif関数とIf関数を使います）
４）雛形は「明細作成用.xlsx」ではなくWordで作成します
（フィールドコードを使います）
以上が可能であれば、マクロなしで実現できます。
３）は必須ではありませんんが、差し込み印刷の実行時にデータの絞り込みが簡単になります。
一番の課題は、フィールドコードを勉強する必要があることです。
（マナ） 2018/04/03(火) 13:00
１）作業シート作成
２）フィルターオプションで１）に抽出
３）明細に６行ずつ転記と印刷
４）これを指定のIDで繰り返す
５）１）のシートを削除
配列をつかわないので、却下かもしれませんが。
（マナ） 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
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
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), ",")
'明細作成用ブックの１番目のシートの２〜最終行を順番にみていって
'コードが配列に含まれるものであれば、シート１にコピペ
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
（もこな２） 2018/04/03(火) 20:34
ありがとうございます。
イメージしていたコードそのものなのでこちらを是非使用させて
いただきたい！と思っています。
ただ
Set srcSH = Workbooks("明細作成用.xlsx").Worksheets(1)
の箇所で「実行時エラー9 インデックスが有効範囲にありません」
と出てしまいます。
明細作成用.xlsxにはシートが全部で2枚ありますが
1枚目をSetしているので問題ないと思うのですが・・・
（マクロン） 2018/04/04(水) 11:07
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
For Each c In t.Sheets("Sheet2").Range("A:A").SpecialCells(xlCellTypeConstants)
の部分で
「実行時エラー9 インデックスが有効範囲にありません」
と出てしまいます。
ｔは開かれていますし、シートも2枚あります・・・・どうしてデバックになるのかわかりません。
（マクロン） 2018/04/04(水) 18:48
とりあえず、今開いているブックを順番に見ていって「明細作成用.xls」があるなら、そのブックの１番目のシートを「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), ",")
'明細作成用ブックの１番目のシートの２〜最終行を順番にみていって
'コードが配列に含まれるものであれば、シート１にコピペ
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
（もこな２） 2018/04/04(水) 19:17
こういうのはフィルターオプションを使いましょうよ。
不要な列の削除や列の並び順の入れ替えなど
（というか必要な項目だけを並べたい順番で書いておいたら）
すごく少ないコードで書けますよ。
（準備は別途必要です。）
（まっつわん） 2018/04/04(水) 19:43
＞また 別の方法でとか差し込み印刷とか○○の方がはやいとかいう回答は望んでおりません。
＞アイデアを募集しておりません。質問の意図と違う回答は望んでおりません。 ＞どなたか質問の意図を理解した回答をお願いいたします。
（マナ） 2018/04/04(水) 20:03
たとえば、形はどうであれ配列つかってればokとか、For〜Nextステートメントを１回以上つかうとか。。。どのような要件を満たす必要があるのか、質問者さんからのレスがないと答えられないですね・・・・
（もこな２） 2018/04/04(水) 21:46
＞元dataシート → 明細作成補助シート → 明細印刷用シートの流れを
＞ダイレクトに
＞元dataシート → 明細印刷用シート 作成の流れにしたく投稿させていただきました。
＞アイデアを募集しておりません。質問の意図と違う回答は望んでおりません。
＞どなたか質問の意図を理解した回答をお願いいたします。
マナさんとまっつわんさんのフィルタオプションのアイデアから、オートフィルタで抽出して、そのままコピペでいいような気もしますが、それが「質問の意図」にあっているのか違っているのか、私にはわかりませんし、仕事を丸投げしておいて、その言い方はないだろうとおもうので、私は降りますね。
（もこな２） 2018/04/05(木) 08:09
デスクトップに
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 '１未満はないだろうが一応
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」について、コードを（自分が見やすいように）整理した上でステップ実行で思うとおり動いているかみたらいいんじゃないですか？
（もこな２） 2018/04/09(月) 12:42
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
ありがとうございます。下記修正してみました。
Set mypath2 = Workbooks.Open(ThisWorkbook.path & "\base2.xlsx").Sheets(1).Range("B16:Q21")
ただws1のタイトル行がmypath2のB16の行に入ってしまいます。
また試しに２ID記入して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
（もこな２） 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」を開いてから一度も変更していないのであれば、そのブックを開きなおすだけなのでエラーにならないですね。失礼しました。
（もこな２） 2018/04/09(月) 22:16
インデントの件何度も申し訳ありませんでした。
以後意識してみます！
変数名も了解しました！ なんでもいいものかと･･･
さて皆様の回答を参考に、下記コードができあがり、
正常に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
＞変数にセットすることができるか解らないので
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
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
＞データ範囲.Range("A" & Rows.Count).End(xlUp).Row 'A列最終行
↑これデータ最終行じゃないです。
しかも、データ範囲に入っているセル範囲は飛び飛びのはずなので、
簡単に6行毎というわけにはいきません。
コピペすると飛び飛びが無くなるので、
6行毎というのが結構簡単になります。
myBook.Range("B16")
↑シートの修飾を忘れています
基本的にセル範囲を操作するのだから、
Rangeオブジェクト（≒セル範囲その物）で変数を定義して、
代入しておけばこんな間違いは減るかなとは思います。
（まっつわん） 2018/04/10(火) 19:26
＞後はこれを6行で印刷。データが終わるまで繰返しにすれば完成なのですが。。。。
余白等を調整して6行しか1ページに収まらないようにしてからオートフィルタを設定したシートを
全ページ印刷したらどうでしょうか。
また、ScreenUpdating 、DisplayAlerts については、まっつわんさんにおなじです。
オマケの部分ですから、ちゃんと動くようになってから自分のすきな時に追加すればいいだけにおもいます。
加えて、 ScreenUpdatingを無効にしている部分が2箇所あるので、かたっぽ要らないですよね。
逆に、DisplayAlertsを戻してないようにおもいますがいいんですか？
（もこな２） 2018/04/10(火) 19:44
'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
ただ（まっつわん） 2018/04/10(火) 19:59
（マナ） 2018/04/10(火) 22:33 の両方とも正常作動しなくて
残念です。
（マクロン） 2018/04/11(水) 09:52
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
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.