[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『納品書の空欄に斜線を引きたい』（yusuke）
お世話になります。 別のシートにて、オートフィルターをかけて納品書に、品名と数量などが表示されま す。（B6:Q6が一行目) B6:Q6に品名と数量が飛んできた時点で、左下から右上に(B13:Q7)に斜線を引きたいのです。 納品の種類数は日々変わるのです。 よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
とんでくるまではすでにあるとして、それ以降。
Sub Test()
Dim y As Long
Dim bX As Double, bY As Double, eX As Double, eY As Double
With Sheets("Sheet1") '納品書シート。シート名は実際のものに変更。
.Lines.Delete
y = .Range("B" & Rows.Count).End(xlUp).Offset(1).Row
If y > 13 Then Exit Sub
With .Range("Q" & y)
eY = .Top
eX = .Left + .Width
End With
With .Range("B13")
bY = .Top + .Height
bX = .Left
End With
.Shapes.AddLine bX, bY, eX, eY
End With
End Sub
（β） 2015/03/24(火) 18:54
（β）さんありがとうございます。 書いてもらったのを、シート名を変えてThisWorkbookにはりつけましたが、間違ってますか？
Sub Test()
Dim y As Long
Dim bX As Double, bY As Double, eX As Double, eY As Double
With Sheets("納品・受領書") '納品書シート。シート名は実際のものに変更。
.Lines.Delete
y = .Range("B" & Rows.Count).End(xlUp).Offset(1).Row
If y > 13 Then Exit Sub
With .Range("Q" & y)
eY = .Top
eX = .Left + .Width
End With
With .Range("B13")
bY = .Top + .Height
bX = .Left
End With
.Shapes.AddLine bX, bY, eX, eY
End With
End Sub
どのような操作が必要なのでしょう （yusuke） 2015/03/24(火) 19:08
アップしたコードはイベント起動ではなく、手動（？）によるマクロ実行タイプです。 ThisWorkbookモジュールでもいいですが、標準モジュールを意識していました。
まずは、納品書シートにオートフィルターの結果をコピペした後の状態でマクロ実行してみてください。 (yusuke)さんの要件を、こちらが正しく理解しているか誤解しているかの確認をしたいので）
このあとですが、逆に、どういったタイミングで自動実行させたいですか？
（β） 2015/03/24(火) 19:14
うまく説明ができないようで申し訳ないです。 今日の作業をした分を日計表と言うシートに貼り付けます。 その時に、納品書のB6:Q13へ品名と数量が飛びます。 納品書のシートを開いた時に、例えば３種類とするとB8:Q8に数字等が入っています。 その時に空白のセルB9:Q13に左下から右上に斜線を引きたいのです。 （yusuke） 2015/03/24(火) 19:25
納品書・受領書シートの 6行目～13行目までには式が埋め込まれているんですか？ であれば、コードを変更する必要があります。
ただ、実行するタイミングが難しいですねぇ。 式が埋め込まれていて、日計表のデータをひっぱってきているとすれば、制御がやっかいです。
オートフィルターと説明がありましたね。 納品書・受領書に値がとんでくるまでの作業手順を具体的に教えてください。 どのシートでオートフィルターを掛けているのか。 そこでフィルタリングされた結果を、どのシートにコピペしているのか。 等々。
（β） 2015/03/24(火) 20:19
こうしましょうか。
納品書・受領書シートのシートモジュールに。 別のシートで作業した後、納品書・受領書シートを開くと自動実行されます。
追記）20:45 納品書・受領書シートの5行目、少なくとも B5 にはタイトルが入っているという前提です。
Private Sub Worksheet_Activate()
Dim y As Range
Dim bX As Double, bY As Double, eX As Double, eY As Double
Lines.Delete
Set y = Range("B5:B13").Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Offset(1)
If y.Row > 13 Then Exit Sub
With y.EntireRow.Range("Q1")
eY = .Top
eX = .Left + .Width
End With
With Range("B13")
bY = .Top + .Height
bX = .Left
End With
Shapes.AddLine bX, bY, eX, eY
End Sub
（β） 2015/03/24(火) 20:35
βさん ありがとうございます。
納品書・受領書シートを開いたらエラーが表示されました。 実行時エラー '91' オブジェクト変数または With ブロック変数が設定されていません。
よろしくお願いします。 （yusuke） 2015/03/24(火) 20:55
Set y = Range("B5:B13").Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Offset(1)
のところが、黄色になっています。 （yusuke） 2015/03/24(火) 20:59
>追記）20:45 納品書・受領書シートの5行目、少なくとも B5 にはタイトルが入っているという前提です。
このようにコメントしていますが、そこはどうですか？
（β） 2015/03/24(火) 21:43
23:50 ちょこっと修正。
もし、B5が空白なら
Private Sub Worksheet_Activate()
Dim y As Range
Dim bX As Double, bY As Double, eX As Double, eY As Double
Lines.Delete
Set y = Range("B5:B13").Find("*", , xlValues, xlWhole, xlByRows, xlPrevious)
If y Is Nothing Then Set y = Range("B5")
If y.Row < 5 Then Set y = Range("B5")
Set y = y.Offset(1)
If y.Row > 13 Then Exit Sub
With y.EntireRow.Range("Q1")
eY = .Top
eX = .Left + .Width
End With
With Range("B13")
bY = .Top + .Height
bX = .Left
End With
Shapes.AddLine bX, bY, eX, eY
End Sub
（β） 2015/03/24(火) 23:11
おはようございます。
B5には"注番"と、タイトルが入っています。 コードを貼り付けて (日計表に３種類を貼り付け）納品書・受領書シートを開くと、B13からQ6まで 罫線が入ります。 ３種類なら B13からQ9まで ４種類なら B13からQ10までと したいのです。
また、B26からQ33に(B6からQ13と同じ）同じ表があります。 そこにも同じように罫線を入れたいのです。 うまく説明できないけど、よろしくお願いします。
（yusuke） 2015/03/25(水) 07:33
>B5には"注番"と、タイトルが入っています
この状態なら、（β） 2015/03/24(火) 20:35 のコードで問題ないと思うのですが？ ここが空白の場合にのみ、
実行時エラー '91' オブジェクト変数または With ブロック変数が設定されていません。
このエラーになるはずですが・・・・・
最近、こちらではうまくいくけど、質問者さんの環境ではＮＧというケースが多く、ちょっと自信喪失気味・・・
で、
「コードを貼り付けて (日計表に３種類を貼り付け）納品書・受領書シートを開くと、B13からQ6まで 罫線が入ります。」
これは、 （β） 2015/03/24(火) 23:11 のコードで、エラーにならず、こうなったということですか？
で、こちらでは、正しく B13 から Q9 に罫線が入ります。ただし、状況としては３件のデータが入っているとすれば B6:B8 には何かしらの値は入っていると理解してますが。
アップした２つのコード、いずれも、B13からQ6まで罫線がひかれるのは、タイトル行のみで あとは空白表示の時のみなんですが？
B26からQ33 については、造作もないことですが、今の状態をクリアしてから追加しましょう。
（β） 2015/03/25(水) 08:32
追加で
B列に入っている実際の式をアップしてもらえませんか。
（β） 2015/03/25(水) 08:36
βさん トンチンカンなおやじで申し訳ないです。
BCD EF HIJK LMN OPQ 5 注番 品名 数量 単価 合計金額 ←式は入っていない 6 ABC 100 － － 7 XYZ 300 － － 8 9 10 この時ならB13からQ8まで 11 12 13
このような表になっています。 私が、コードの貼り付けるどころを間違ってるのでしょうか。 納品書・受領書のシートを右クリックしてコードの表示をクリックして 開いたところ Sheet4(納品・受領書）に貼り付けました。
（yusuke） 2015/03/25(水) 09:08
BCD や EF といったところ、結合セルですか。
まぁ、それはさておき、何度か
>３件のデータが入っているとすれば B6:B8 には何かしらの値は入っていると理解してますが。
とコメントしていると思いますが？ アップされた例では空白ですね。 なので、マクロは、6行目まで空白、つまり空っぽだと思い、表全体に斜線を引いたんですよ。
まぁ、気を取り直して。
のちほど、シート内の別表にも斜線を引くのと合わせて改訂版をアップします。
（β） 2015/03/25(水) 12:14
おっしゃるように BCD EF は結合セルです。 また、B6:B8 は空白です。 （yusuke） 2015/03/25(水) 12:19
5行目だけではなく、表の該当列も同じ結合がされていると考えていいですね。
これまでの障害は、B列(B:D列)に値がなかったことと、結合セルだったことが原因です。 その対応をしました。 （最初にアップしたコードの構えでもよかったのですが、後からアップしたものをベースにしました）
以下で置き換えてください。
Private Sub Worksheet_Activate()
Lines.Delete
MakeUp Range("B5:Q13")
MakeUp Range("B25:Q33")
End Sub
Private Sub MakeUp(listR As Range)
Dim y As Range
Dim searchR As Range
Dim bX As Double, bY As Double, eX As Double, eY As Double
Set searchR = listR.Columns(4).Resize(, 2)
Set y = searchR.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious)
If y Is Nothing Then Set y = listR.Cells(1)
If y.Row < listR.Row Then Set y = listR.Cells(1)
Set y = y.Offset(1)
If y.Row > listR.Row + 12 Then Exit Sub
With y.EntireRow.Range("Q1")
eY = .Top
eX = .Left + .Width
End With
With listR.Cells(listR.Rows.Count, 1)
bY = .Top + .Height
bX = .Left
End With
Shapes.AddLine bX, bY, eX, eY
End Sub
（β） 2015/03/25(水) 13:17
（β)さんありがとうございます。 思い通りのファイルになりました。 下の方もできてますね。 私の、説明不足のために、お手を煩わせてしまいました。 お詫びいたします。 併せて感謝します。 本当にありがとうございました。
（yusuke） 2015/03/25(水) 14:36
もう一つ! 罫線の色を黒にするにはどうすればいいですか。
別のファイルですが 同じような状態です。
納品書 受領書
10 AB C DE GHIJ MN O PQ RSTU 11 品名 数量 単価 金額 品名 数量 単価 金額 12 ABC 30 － － ABC 30 － －
13 14 15 16 ・ ・ ・ ・ ・ 36 先のコードを変更してお願いします。 できましたら、簡単にわかりますようコードの意味を教えてもらえると嬉しいですが よろしくお願いします。
（yusuke） 2015/03/25(水) 15:29
黒にするには
Shapes.AddLine bX, bY, eX, eY
これを
With Shapes.AddLine(bX, bY, eX, eY).Line
.ForeColor.RGB = vbBlack
End With
別レイアウト対応のコードは後ほど。
（β） 2015/03/25(水) 16:11
新レイアウト版です。このシートのシートモジュールに。
なお、今回のMakeUp は かなり汎用的に作ってあるので、もし、前のシートと、このシートが同じブックなら シートモジュールではなく ThisWorkbookモジュールに、両方の処理を記述することも可能。
今回のMakeUp は
第１引数 タイトル行含む、表全体の領域 第２引数 データ件数を調べるために用いる列の、表の中での位置。左から 1,2,3,4,・・・ 第３引数 その列が結合されている場合、何個のセルが結合されているかを指定。結合がなければ指定不要。
なので、前のレイアウトのコードも、このMakeUpに変え、引数指定を上記のようにしてやれば、ＯＫになる。
ところでアップされた左側の表の最後、RSTU となっているけど、きっと STUV だよね？
Private Sub Worksheet_Activate()
Lines.Delete '処理前にシート上の線をすべて消す
MakeUp Range("A11:J36"), 1, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
MakeUp Range("M11:V36"), 1, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
End Sub
'listR : タイトル行含めた表の領域 'checkCol : 件数を調べるために使う表内の列番号 'mCols : チェックすべき列の結合数。省略可。
Private Sub MakeUp(listR As Range, checkCol As Long, Optional mCols As Long = 1)
Dim y As Range
Dim searchR As Range
Dim bX As Double, bY As Double, eX As Double, eY As Double
'検索結合列領域を取得。（結合列では、単独の列でのFindができないため）
Set searchR = listR.Columns(checkCol).Resize(, mCols)
'検索領域の下から、なんらかの値があるセルを取得。
'式による空白がある場合のデータ最終行を求める場合の定番処理。
Set y = searchR.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious)
'最低限、タイトル行があるはずなので、以下は不要だけど
'仮に、この列のシートの１行目まで空白なら Nothing が返るので
'その場合はタイトル行のセルを検索結果とする。
If y Is Nothing Then Set y = listR.Cells(1)
Set y = y.Offset(1) '斜線を引くセルは、実際にデータのある行に１行下。
'その行番号が、表の領域の最後の行番号より大きければ空白行なし。処理終了。
If y.Row > listR.Row + listR.Rows.Count - 1 Then Exit Sub
'空白領域の右上隅のセル
With y.EntireRow.Cells(1, listR.Column + listR.Columns.Count - 1)
eY = .Top 'そのセルの上端
eX = .Left + .Width 'そのセルの左端 + そのセルの幅
End With
'領域の左下隅のセル
With listR.Cells(listR.Rows.Count, 1)
bY = .Top + .Height 'そのセルの上端 + そのセルの高さ
bX = .Left 'そのセルの左端
End With
'斜線を引く。引数は、開始横位置、開始縦位置、終了横位置、終了縦位置
With Shapes.AddLine(bX, bY, eX, eY).Line
.ForeColor.RGB = vbBlack 'その線の色を黒に。
End With
End Sub
（β） 2015/03/25(水) 17:10
（β)さん本当にありがとうございます。 殆ど無知な私に親切丁寧なご教授に感謝です。 アップして頂いたコードをじっくり読んで、しっかり理解できるように なればいいなと思います。 勉強させてもらいます。 今後ともよろしくお願いします。 （yusuke） 2015/03/25(水) 17:37
再度のお願いです。 先に書いていただいたコードは使用させてもらっていますが、新しく注番の域を挿入しました。 その際には、（β） 2015/03/25(水) 17:10のコードのどこをどのように修正すればいいのですか？ A12:A36とN12:N36は、自身で打ち込みするようになっています。 よろしくお願いします。
納品書 受領書
10 A BC D F HIJK N OP Q S TUVW 11 注番 品名 数量 単価 金額 注番 品名 数量 単価 金額 12 ABC 30 － － ABC 30 － － 13 14 15 16 ・ ・ ・ 36
（yusuke） 2015/03/29(日) 11:33
この時には、A36からH13とN36からT13に斜線を引きたいのです。 （yusuke） 2015/03/29(日) 11:55
前のレイアウト説明でもずれていたけど、左の表の金額列は TUVW じゃなく、UVWX でしょ？
で、（β） 2015/03/25(水) 17:10 のアップの際、「汎用的に作った」と自慢（？）しているけど MakeUp はそのままコピペ。Worksheet_Activate の MakeUp への引数のみを、
新しい表の領域,件数チェック列,その結合列数
このように与えればいいですよ。
Private Sub Worksheet_Activate()
Lines.Delete '処理前にシート上の線をすべて消す
MakeUp Range("A11:K36"), 2, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
MakeUp Range("N11:X36"), 2, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
End Sub
（β） 2015/03/29(日) 13:14
ありがとうございます。 出来ましたが、ちょっと教えてください。
MakeUp Range("A11:K36"), 2, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
MakeUp Range("N11:X36"), 2, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
MakeUp Range("A11:J36"), 1, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
MakeUp Range("M11:V36"), 1, 2 '表の領域とチェックすべき列情報を与えて MakeUp 実行
⇑
ここの ,1,2 ,2,2は、どこを指しているのですか
（yusuke） 2015/03/29(日) 13:47
MakeUp Range("N11:X36"), 2, 2
N11:X36 はいいですよね。
で、最初の 2。コード内の説明にもあるように、これはその領域（N11:X36) の中の 何列目でデータの入っている最終行を求めるか ということです。 ここは、その行にデータがあれば、必ず、なんらかの値が入っている場所を指定します。 この例では 2 列目、つまり、 O列 という指定です。
２番目の 2。コード内の説明、ちょっとわかりにくかったかもしれませんが、列が結合されていた場合、 単独列指定の Findメソッドは失敗します。ですから、O列がP列と結合されている状態なら 2 列 という意味で 2 です。
（β） 2015/03/29(日) 15:35
ありがとうございます。 懇切丁寧な解説、トンチンカンな親爺にも理解ができました。 また、質問をするかと思いますがその節にも、よろしくお願いします。
（yusuke） 2015/03/30(月) 09:15
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.