[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『抽出したデータ数に応じた印刷範囲設定をするには』（まりこ）
VBAを触り始めた初心者です。
会社で作成しているのですが、どうしても分からないため、
教えてもらいたいです。
(シート仕様)
・約1万件くらいの備品の期限管理
・シート1で期限を過ぎていたものは"NG"と表記
・"NG"と表記の分をシート2に抽出
・シート2は100件を1ページとする
・抽出データが100件を超えた場合、次ページとする
・シート2に印刷ヘッダを設定、1行目～2行目とする
・シート2の最終行に担当者印欄を設ける
(このような感じ)
シート1
A B C D
確認日 2015/4/10 ←←←「=today()」が入っています。
No. 名称 期限 判定
1 精米 2015/4/10 NG
2 備蓄米 2015/4/11 OK
3 生成米 2015/4/15 OK
4 加工米 2015/4/19 OK
5 加工米 2015/4/09 NG
・
・
・
↑
「=IF(C3<B1,"NG","OK")」が入っています。
シート2
No. 名称 期限 判定
1 精米 2015/4/10 NG
5 加工米 2015/4/09 NG
担当者印:印
このような仕組みってできるのでしょうか？
教えていただいた内容で自己学習踏まえ、勉強したいと思います。
お分かりの方、ご教授お願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
抜出そのものは、オートフィルター、あるいはフィルター詳細設定（フィルターオプション）で可能です。 また、抜出だけを目的にすれば、判定列はなくてもできます。 シート１の情報としてOK/NGを表記したいということであれば、別ですが。
あとは、抜き出したものを１００行ずつループで取り出して新しいシートに転記していくことになります。
ループは別にして、オートフィルターによる抽出とコピー、フィルターオプションによる抽出。 これを操作しながらマクロ記録をとると、そこまでのコードが生成されます。
最終形まで一式のコードを、はいどうぞ と提示するより、ＶＢＡをこれから勉強していこうとする（まりこ）さんにとっては、そのアプローチのほうがいいのではないでしょうか？
そのあと、最終形にもっていくまでの部分で壁がいくつもあると思いますので、そこは、ＳＯＳを出してもらえれば お手伝いします。
それと、=TODAY() を使うのは、個人的には好きではありません。 日が変われば自動的に値が変わって便利だということなんでしょうけど、この処理そのものは、たとえば 昨日行ったけど、データが不足していた、あるいは、期限日付が違っていたので直した。 こうした後、再度実行。 この時、日付は、もう、今日になっていますので、昨日時点の再処理ができないですね。
=TODAY() を使わず、基準日を入力してから実行するという構えがいいと思います。
（β） 2015/04/14(火) 09:27
抽出部分は、オートフィルタとコピーでマクロの記録でも出来そうです。
マクロでの印刷はなかなか難解ですね。 βさんのように1頁ずつ印刷が簡単だと思いますが、ちょっと考えたので印刷設定の例だけ。
全自動を目指しましたが、拡大率はあらかじめ手動設定の半自動です。 FitToPagesTall を使おうとしましたが、100行ずつというコントロールが出来ませんでした。
Sub 印刷設定()
Dim 印刷シート As Worksheet
Set 印刷シート = Worksheets("Sheet2")
印刷シート.ResetAllPageBreaks
With 印刷シート.PageSetup
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = ""
.Zoom = 55 '// 拡大率：あらかじめ102行が十分入る大きさを設定しておく。
End With
Dim r As Long
For r = 102 To 印刷シート.Cells(Rows.Count, "A").End(xlUp).Row Step 100
印刷シート.HPageBreaks.Add before:=Range("A" & r)
Next
End Sub
（Mook） 2015/04/14(火) 10:57
Mookさんからオートフィルターでの処理案がでていますので、フィルターオプション（フィルター詳細設定）を使った例を。
ただ、オートフィルターにしてもフィルターオプションにしても、一度、操作で、その機能を体験してください。 で、次にそれをマクロ記録してみてください。そこで生成されるコードと、回答としてアップされたコードを比較し 「粗けずり」のマクロ記録自動生成コードと、そのブラッシュアップ方法につき、目で見て体感してください。
Sub TestFilterOP()
'フィルター詳細設定を使った処理
Dim listA As Range
Dim listR As Range
Dim critR As Range
Dim z As Long
Dim i As Long
Dim newSh As Worksheet
Dim mySh As Worksheet
Application.ScreenUpdating = False '処理中の画面の動きを隠す
Set mySh = Sheets("Sheet1") '元シート。★シート名は実際のものに。
With mySh.Range("A1").CurrentRegion '元シートの１行目を含むデータ領域
Set listA = .Offset(1).Resize(.Rows.Count - 1) '１行目を除くリスト領域
'リスト領域の右側を作業域として使用
Set listR = .Cells(, .Columns.Count + 2).Resize(, 4) '抽出用ヘッダー領域をリスト領域から１列離れたところに作成
listR.Value = listA.Rows(1).Value '抽出用ヘッダー項目をセット
Set critR = .Cells(, .Columns.Count + 7).Resize(2) '抽出条件領域を抽出用ヘッダー領域から１列離れたところに作成
critR(1).ClearContents '抽出条件項目名を空白に
critR(2).Formula = "=C3<$B$1" '抽出条件式
End With
'フィルターオプションで該当のものを抽出
listA.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critR, CopyToRange:=listR, Unique:=False
z = listR.CurrentRegion.Rows.Count '抽出領域の最終行番号
'100行ずつ分解して別シートにコピー
For i = 2 To z Step 100
Set newSh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'元シートの列幅をコピー
mySh.Cells.Copy
newSh.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
newSh.Range("A1:B1").Value = mySh.Range("A1:B1").Value
listR.Copy newSh.Range("A2") 'タイトル
listR.Offset(i - 1).Resize(100).Copy newSh.Range("A3")
'最終行から１行あけたところに担当者欄
With newSh.Range("A" & Rows.Count).End(xlUp).Offset(2)
.Value = "担当者印"
With .Offset(, 1).Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
'印刷行タイトル設定
newSh.PageSetup.PrintTitleRows = "$1:$2"
Next
'作業領域のクリア
listR.CurrentRegion.Clear
critR.Clear
ThisWorkbook.Save
End Sub
（β） 2015/04/14(火) 13:29
Mookさんのコードを見て、私が要件を取り違えていることに気が付きました。 抽出してできあがるシートは１枚だけだったんですね。 後ほど、改訂版をアップします。
（β） 2015/04/14(火) 14:04
フィルターオプション案 再掲します。 実際の操作と照らし合わせやすいように、できるだけ領域は固定で指定しました。 転記シート側、タイトル部分+100行（最終ページは担当者印欄もあわせて）が１ページに収まるような 設定はあかじめしてもらっているという前提です。
Sub TestFilterOP2() 'フィルター詳細設定を使った処理
Dim listA As Range
Dim i As Long
Dim newSh As Worksheet
Dim mySh As Worksheet
Application.ScreenUpdating = False '処理中の画面の動きを隠す
Set mySh = Sheets("Sheet1") '元シート。★シート名は実際のものに。
Set newSh = Sheets("Sheet2") '転記シート。★シート名は実際のものに。
newSh.UsedRange.ClearContents '転記シートをクリア
newSh.Columns("B").Borders.LineStyle = xlNone '担当者印欄罫線クリア
newSh.Range("A1:D2").Value = mySh.Range("A1:D2").Value 'ヘッダー部分の転記
mySh.Range("F2").Formula = "=C3<$B$1" '抽出条件式
'元シートの１行目を除くリスト領域
Set listA = mySh.Range("A2", mySh.Range("A" & Rows.Count).End(xlUp)).Columns("A:D")
'フィルターオプションで該当のものを抽出
listA.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=newSh.Range("F1:F2"), CopyToRange:=newSh.Range("A2:D2"), Unique:=False
'印刷行タイトル設定
newSh.PageSetup.PrintTitleRows = "$1:$2"
'ページ替え設定。Mookさんのコードを借用
newSh.ResetAllPageBreaks
For i = 102 To newSh.Range("A1").CurrentRegion.Rows.Count Step 100
newSh.HPageBreaks.Add before:=Range("A" & i)
Next
'最終行から１行あけたところに担当者欄
With newSh.Range("A" & Rows.Count).End(xlUp).Offset(2)
.Value = "担当者印"
With .Offset(, 1).Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
'作業領域のクリア
newSh.Range("F1:F2").Clear
newSh.Select
End Sub
（β） 2015/04/14(火) 16:16
βさんから既に回答が出ているので不要とは思いますが、 単純比較での記念参加です。
署名は下線の手抜きです:-p
Const 管理シート名 = "Sheet1" Const 印刷シート名 = "Sheet2"
Sub 期限切れ抽出()
Dim 管理シート As Worksheet
Set 管理シート = Worksheets(管理シート名)
Dim 印刷シート As Worksheet
Set 印刷シート = Worksheets(印刷シート名)
Dim 最終列 As Long
最終列 = 管理シート.Cells(Rows.Count, "A").End(xlUp).Row
Dim 出力行 As Long
出力行 = 3
印刷シート.Range("A3").Resize(Rows.Count - 2, Columns.Count).Clear
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim チェック行 As Long
For チェック行 = 3 To 最終列
If 管理シート.Cells(チェック行, "D").Value = "NG" Then '// NG のある列
管理シート.Cells(チェック行, "A").Resize(1, 8).Copy 印刷シート.Cells(出力行, "A").Resize(1, 8) '// とりあえず8列コピー
出力行 = 出力行 + 1
End If
Next
印刷設定
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub 印刷設定()
Dim 印刷シート As Worksheet
Set 印刷シート = Worksheets(印刷シート名)
印刷シート.ResetAllPageBreaks
With 印刷シート.PageSetup
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = ""
.Zoom = 55 '// 拡大率：あらかじめ102行が十分入る大きさを設定しておく。
End With
With 印刷シート.Cells(Rows.Count, "A").End(xlUp).Offset(2, 1) '// 最終行の後ろのB列に署名
.Value = " 担当者印 "
.Font.Underline = xlUnderlineStyleSingle
End With
Dim 改ページ行 As Long
For 改ページ行 = 102 To 印刷シート.Cells(Rows.Count, "B").End(xlUp).Row Step 100
印刷シート.HPageBreaks.Add before:=Range("A" & 改ページ行)
Next
End Sub
（Mook） 2015/04/14(火) 17:09
色々ご教授、ありがとうございます。
正直、まだちんぷんかんぷんで焦っています。
最後はお二人のより良い改善案での投げかけあい、
早くその中に入れればと思っています。
まだコードの解析が全部は無理なので、少しずつQ＆Aを出させてください。
βさんのおっしゃる「=today()」関数のご注意、なるほどですね。
私はなるべく手動入力箇所を減らしという観点で利用していましたが
開ける時間で変わるから、あまり台帳等には向いていないかもしれません。
検討してみます。
次にMookさんのご教授いただいた、
Dim 出力行 As Long
出力行 = 3
印刷シート.Range("A3").Resize(Rows.Count - 2, Columns.Count).Clear
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim チェック行 As Long
For チェック行 = 3 To 最終列
If 管理シート.Cells(チェック行, "D").Value = "NG" Then '// NG のある列
管理シート.Cells(チェック行, "A").Resize(1, 8).Copy 印刷シート.Cells(出力行, "A").Resize(1, 8) '// とりあえず8列コピー
出力行 = 出力行 + 1
End If
Next
ですが、私の解釈として…
1.印刷シートの開始は3行目
2.不要データ対策として印刷シートをクリア
3.チェック行～最終行まで検索
4."NG"の文言があればその行1～8列目までコピーし、印刷シートへ
※これを最終行まで行う(for～next)
まぁそのままでは？と言われると…
ちなみに
「印刷シート.Range("A3").Resize(Rows.Count - 2, Columns.Count).Clear」
このクリアのステップですが、「Range("A3")」の示している意味が分かりませんでした。
試しに「Range("A4")」に変更すると
「実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです」
と表示されます。
エラー内容としてはありえない値を指定した場合に出るみたいなのですが、
(シートが3枚しかないのに4枚目を指定しようとしたetc)
上での私の解釈では問題ないと思っていたのですが。
細切れでの確認となりますが、もう少しお付き合い願いますでしょうか。
お手隙の時でよろしくお願いします。
（まりこ） 2015/04/14(火) 21:58
は少しめんどくさい指定のしかたなのですが、シート全体の3行目以降を指しています。 ですので、A4にしてしまうと Rows.Count - 2 が実際の行数より多くなってしまうので、 ここも Rows.Count - 3 にしないとエラーになります。
With 印刷シート
.Range("A3",.Cells(Rows.Count,Columns.Count)).Clear
End With
と書いた方が、融通が利いたかもしれません。
>2.不要データ対策として印刷シートをクリア というよりは、毎回 NG のものを書き出す処理と解釈したので、一旦データを白紙にして いる意味合いです。
あとは、書かれている解釈の通りかと思います。
（Mook） 2015/04/14(火) 22:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.