エクセル 2010 マクロ 残セル表示と印刷

質問

A列～N列迄データが入力されている発注表があります。
毎日、入荷現品と照合して、合致したら該当品のC列に日付を入力しています。
合致項目はD～H列の製品番号のいずれとK列の数量です。
製品番号は各行に１番号のみ入力されています。
ただ、それがD列だったり、F列だったりします。
A～N全てが空白の行もあります。
行数はシートによって一定ではありません。

毎日C列に日付が埋められていくわけですが、
例えば、空白セルが残り3個になったら　「残り3品目です」。2個だったら「残り2品目です」のように
残り1品目になるまで、C列に日付を入力すると
メッセージボックスで知らせてくれるようなことができましでしょうか？

また、残りが0品目。
すなわちデータが何も入っていない行を除いたC列全てに日付が入力されたら
データが入力されている最終セルまでの下線部に実線を入れ(A～N)、
印刷日をN1セルに入力、
A～Nが全て収まり横向きで印刷をすることも出来ますでしょうか？
行方向は分割されて構いません。

その時、I列以外は列幅13で、I列のみAutofitで文字幅に合わせるようにしたいです。

回答No.2

WindFaller · ベストアンサー

こんにちは。

>セル幅や縮小、横向きなどは自動で行われ印刷されるようにしたいです。
最後の印刷ついては、次回にしてください。

変更したコードは、下に書いておきます。'* が変更部分です。
本来は、コードをそのまま残して修正部分を書きたかったのですが、一部で、End With の位置を変えたり、変数を加えたりしたので、「Sub 検索()」は、全文を書き出しました。また、ユーザー定義関数の「DoubleCountBlank()」を作りました。「Sub 検索()」は、入れ替え、「DoubleCountBlank()」は、貼り付けてください。

>c.Activate '←出来ればEFGHのいずれかに入力されているデータをアクティブしたい。1行に対して>EFGH列のいずれにだけSheet1のA1に対する検索データが入っている

その部分は、
c.End(xlToRight).Activate 'Offset(0, 3).Activate '*
こんな風にカーソルを飛ばしてみたらいかがでしょうか。そうでないなら、Office(0,3)にしてください。

> Ws2.Select '←Ws2を表示させたいのですがselectを使わない方法を教えてください
Application.Goto Ws2.Range("A1"), True

という書き方があります。指定セルまで飛びます。第2パラメーターの　「True」は、その指定した場所に、例えば、"Z100"などになると、その指定した場所が左上端になります。"A1"では、あまり変わりませんが。

今回は、オブジェクトの開放はしていませんが、ローカル・マクロが終了すれば、オブジェクトは開放されてしまいます。今後の展開を考え、それは入れないでおきます。

'//
Sub 検索()
　'Ver. 0.3 --2014.04.23　
　Dim Ws1 As Worksheet, Ws2 As Worksheet
　Dim strKey As Variant
　Dim s As String
　Dim c As Range, bln As Boolean
　Dim rng1 As Range '*
　Dim cnt As Long '*

　Set Ws1 = Sheet1
　Set Ws2 = Sheet2

　Ws1.Select

　With Ws2
　　strKey = Application.Transpose(.Range("A1").Resize(2).Value)
　　strKey = Join(strKey, "")
　End With

　If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub

　With Ws1
　　Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp)) '*
　　For Each c In rng1.Offset(, -10)

　　　'E,F,G,H を検索

　　　s = c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 10).Value

　　　If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then '変更を加えた
　　　　c.Offset(0, 2).Value = Date
　　　　c.End(xlToRight).Activate 'Offset(0, 3).Activate '*

　　　　c.Resize(1, 14).Interior.ColorIndex = 6
　　　　bln = True
　　　　Exit For
　　　End If
　　Next c

　　If Not bln Then
　　　Ws2.Select
　　　MsgBox "リストに存在しません", vbExclamation, "NotFound"
　　Else '加える
　　　Call ReSearch(Ws1.Range("M2"), c.Row)
　　　'再設定
　　　Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp))
　　　MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation '*　ユーザー定義関数へ
　　End If
　End With
　Application.Goto Ws2.Range("A1"), True '*
End Sub

'//ユーザー定義関数

Function DoubleCountBlank(rng1 As Range, rng2 As Range)
'横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2)
　Dim i As Long
　Dim cnt As Long
　For i = 1 To rng1.Rows.Count
　　If VarType(rng2.Cells(i, 1)) = vbDouble Then
　　　If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then
　　　　cnt = cnt + 1
　　　End If
　　End If
　Next i
　DoubleCountBlank = cnt
End Function

'//

だいぶ、全貌が分かってきました。
今、手をつけるとグチャグチャになってしまいますが、この先、maron1010さんご自身で、コードの内容を、整理し直したほうがよいでしょうね。私が書いたものを含めて、継ぎ足し状態で、他人のコードの寄せ集めは、管理しづらいものです。アイデアだけを採用して、組み直した方がよいかもしれません。

なお、StrComp(s, strKey, vbTextCompare) = 0　と変更を加えたのは、私のマクロを書くスタイルです。文字列比較する時、Excel VBAは、あまり柔軟に対応しません。小文字・大文字などは、本来、考慮に入れませんので、TextCompare（テキスト比較）にしました。他にも、IntStr関数なども良いと思います。

ただ、あまりPCに慣れていない人は、思わぬ使い方をしますので、十二分に、エラー対策はしたほうがよいですね。そこで、私は、起動時にバックアップを取るマクロなどを考えだしました。

お礼

一度、こちらの質問を閉じさせていただきます。
補足質問については新たに投稿いたしますので、そちらで宜しくお願い致します。
色々とありがとうございました。

補足

いつもありがとうございます。
実は、、、と言うかお察ししているかと思いますが、
私はコードの内容は全くと言っていい程分からないのです。
ご教示していただいたものを、あれこれアレンジする技量も知識もないため
憤りを感じるかと思いますがご了承ください。

ご教示頂いたコードで動作確認致しました。
毎度の事乍ら、私の稚拙な文章から的を射たコードを提示して頂き、喜びと驚きです。

ただ・・・誠に申し訳なく言いにくいのですが、一つ別な問題が発覚しました。
再び稚拙な文章世界へお付き合いください。

たぶんサブルーチン辺りを変えると思うのですが・・・

まず、Ws2のA1セルが'E,F,G,H を検索　を　D列も含め
'D,E,F,G,H を検索してD,E,F,G,H に検索対象があった時
Dだったらそのまま上に何か入力されているセルを検索、
また、E,F,G,Hのいずれかだったら左横列の上に向かって
(EならD　、FならE ・・・という具合に)
何か入力されているセルのM列の191000####をmsgboxで表示させたいです。

但し、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合
M列の一番上から検索してヒットした191000#### &「これは例外です」を
msgboxで表示させたいです。

基本的にD列にデータがある場合のM列は191000####ですが
稀に191000####以外がある為です。

もう暫く我が儘聞いて頂けますでしょうか？
宜しくお願い致します。

回答No.1

WindFaller

こんにちは。

>残り1品目になるまで、C列に日付を入力すると
入力といっても、今までの流れからすると、日付を入れること自体が、マクロでは……？
それはどちらでもよいことですが、一応、単独の質問として、捉えれば、イベントになるはずです。

しかし、
>毎日C列に日付が埋められていくわけですが、
>空白セルが残り3個になったら　「残り3品目です」。2個だったら「残り2品目です」のように残り1品目になるまで、

質問文の中で、何に対して、空白セルが何個かというものが、良く分からないですね。そもそも、図自体の意味が、こちらは分かりません。

空白セルが何個か数えるのは、CountBlank であっても、C列に対してですか？しかし、C列には、日付ではない記号を入れている行もあります。そうすると、日付を入れた行のA列～N列までを対象にするようにも思えます。

状況説明も良いのですが、プログラム的というか、数学的に書かれていないと、答えが出来ないのです。

その次の
>その時、I列以外は列幅13で、I列のみAutofitで文字幅に合わせるようにしたいです。

Sub ArrangeCellWidth()
With Columns("A:H")
　　.Cells.Columns.ColumnWidth = 13
End With
　　Columns("I").AutoFit
End Sub

>A～Nが全て収まり横向きで印刷をすることも出来ますでしょうか？
Excel 2010 でしたら、ページレイアウト・モードにして、全体の縮小を掛けるなどすればよいと思います。マクロにするべきかどうか、迷うところです。それは、常に大きさの変化するシートならともかく、ふつうは、レイアウトが1つに決まれば、変えることはないような気がします。

補足

毎度乍らの語弊だらけで稚拙な文章、誠に申し訳ありません。
一応、今までの流れを踏襲してはいるものの、
列の並び等が今回独自のものになっていますので、ご了承ください。
実際に使用しているコードを下に置きました。

>残り1品目になるまで、C列に日付を入力すると
マクロを使ってC列に日付が入力されると・・・

>毎日C列に日付が埋められていくわけですが、
>空白セルが残り3個になったら　「残り3品目です」。2個だったら「残り2品目です」のように残り1品目になるまで
C列には日付以外も含まれています。
C列の空白セルをカウントするのは6行目から。
K列に数量がある行のC列に、マクロを使って日付が入ります。
K列に数量があって且つC列のセルが空白の時、残り3個になったらmsgboxで「残り3品目です」。・・・(略)
K列が空白でC列も空白の時はC列は空白残数としてカウントしない。

前回msgboxで　"これは1100XXXXXXのグループです"を表示するように独自でやりました。
そこで、その後にmsgboxで「残り3品目です」を表示させたいです。
因みに実際に使用しているコードは以下のとおりです。

Sheet1(シート名は常に変わる)に
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address <> "$A$3" Then Exit Sub
Call 検索
Range("A1:A2").Clear
Range("A1").Activate
End Sub

Sub 検索()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim strKey As Variant
Dim s As String
Dim c As Range, bln As Boolean

Set Ws1 = Sheet1
Set Ws2 = Sheet2

Ws1.Select　

With Ws2
strKey = Application.Transpose(.Range("A1").Resize(2).Value)
strKey = Join(strKey, "")
End With

If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub

With Ws1
For Each c In .Range("K2", .Cells(Rows.Count, "K").End(xlUp)).Offset(, -10)

'E,F,G,H を検索
s = c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 10).Value

If s = strKey And c.Offset(0, 2).Value = "" Then
c.Offset(0, 2).Value = Date
c.Activate '←出来ればEFGHのいずれかに入力されているデータをアクティブしたい。1行に対してEFGH列のいずれにだけSheet1のA1に対する検索データが入っている

c.Resize(1, 14).Interior.ColorIndex = 6
bln = True
Exit For
End If
Next c
End With
If Not bln Then
Ws2.Select　
MsgBox "リストに存在しません", vbExclamation, "NotFound"
Else '加える
Call ReSearch(Ws1.Range("M2"), c.Row) '加える
End If
Ws2.Select　'←Ws2を表示させたいのですがselectを使わない方法を教えてください

End Sub

'//サブルーチン
Sub ReSearch(Rng As Range, j As Long)
'最初のセル, 終わりの行数
Dim i As Long
Dim Ws As Worksheet
With Rng.Parent 'イレギュラーな書き方で、Rangeからシートオブジェクトを出しました。
For i = j To Rng.Row Step -1 '上に戻っていきます。
If CStr(.Cells(i, Rng.Column).Value) Like "1100######" Then '文字列比較

'.Cells(i, Rng.Column).Offset(, 2).Value
MsgBox "これは" & CStr(.Cells(i, Rng.Column).Value) &"のグループです"
Exit For '見つけたら離脱
End If
Next i
End With

End Sub

印刷については、シート上にボタンを配して、ボタンをクリックすると
(パソコンに疎い方にも使えるように)セル幅や縮小、横向きなどは自動で行われ印刷されるようにしたいです。

宜しくお願い致します。