[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『検索』(ふみ)
A B C D E F G H I
1 図番 名称 数量 区分 取引先コード 取引先名 価格 納期 見積有効期限
2 ABC-1234567 防着板1 1 正規 A1234 アイウエオ製作所 10,000 受注後30日 2017/3/31
3 正規 A2468 イロハニ精機 15,000 受注後20日 2017/4/30
4 正規 A3691 なんでも加工 12,000 受注後25日 2017/2/15
5
6 SSR-246810 サブユニット 1 正規 A0012 岩谷産業 100,000 受注後30日 2017/4/30
7 一時 A1256 ヨシダ印刷 110,000 受注後50日 2017/6/30
8 正規 A8765 井上プラスチックス 120,000 受注後45日 2017/3/31
9 正規 A0001 株式会社トヨフク 90,000 受注後30日 2017/4/30
こんにちは。
うまく書けないのですが、Sheet2にデータベースとして、上の様な表を作ります。
ABCは一つだけですが、ABCに対して複数の取引先をデータベースとして
登録するので、D〜Iは何行になるかわかりません。
この例では区切として5行目を空けて、6行目から次の図番を記入しています。
Sheet1のD3セルに図番を記入してボタンを押すと、Sheet2に同じ図番が
記入されていれば、Sheet1のF3セルに名称、H3セルに数量、
B8セルに区分、C8セル 取引先コード、D8セル 取引先名、
E8セル 価格、F8セル 納期、G8セル 見積有効期限、 を
転記させたいです。
そして取引先が複数あれば、B9〜G9以降の次の行へ転記させたいです。
同じ図番がなければ「登録されていない図番です」のメッセージを出したいです。
取引先数が不確定の為、コードをどう書いて良いかわかりません。
またこれは出来ればですが、見積有効期限が本日を過ぎていれば
セルを塗りつぶしたいです。
細かいアレンジは自分で出来ると思いますが、基本となるコードを
教えて下さい。よろしくお願い致します。
< 使用 Excel:Excel2007、使用 OS:Windows7 >
With Sheets("2") If .AutoFilterMode Then .AutoFilterMode = False Selection.AutoFilter Sheets("2") .Range("A:X").AutoFilter Field:=1, Criteria1:=Worksheets("1").Range("A1").Value End With
Set rng = Sheets("2") _
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Range("A1").CurrentRegion.SpecialCells(xlVisible).Copy _
Destination:=rng
rng.EntireRow.Delete Shift:=xlUp
Sheets("1").Select Range("A2").Select ActiveSheet.Paste
Sheets("2").Select Application.CutCopyMode = False Selection.AutoFilter
End Sub
(11) 2017/01/12(木) 11:00
とりあえず別案なぞ。Sheet1のシートモジュールとして貼ってください。
Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long Dim j As Long Dim iMax1 As Long Dim iMax2 As Long
If Target.Address <> "$D$3" Then Exit Sub
iMax1 = Cells.SpecialCells(xlCellTypeLastCell).EntireRow.Row If 7 < iMax1 Then Range("F3,H3,B8:G" & iMax1).ClearContents End If
With Sheets("Sheet2") iMax2 = .Cells.SpecialCells(xlCellTypeLastCell).EntireRow.Row For i = 2 To iMax2 If .Cells(i, "A").Value = Target.Value Then Exit For End If Next i
If iMax2 < i Then MsgBox "登録されていない図番です", vbCritical, "エラー" Else Range("F3") = .Cells(i, "B").Value Range("H3") = .Cells(i, "C").Value
For j = i + 1 To iMax2 If .Cells(j, "E").Value = "" Then Exit For End If Next j
.Range(.Cells(i, "D"), .Cells(j, "I")).Copy Range("B8") End If End With End Sub (???) 2017/01/12(木) 11:10
???さん、いつもありがとう御座います。
丸投げと叱られるのを承知でお願いしてしまいました。
見事に動作しましたが、コードが難しくてこれから理解するのが大変と感じます。
アレンジする為には必要なので、勉強します。
ありがとう御座いました。
(ふみ) 2017/01/12(木) 11:39
今回の場合は、図番の一致する行をIf文で探して、見つけたら今度は空欄行が出てくるまでをコピー対象にする、というだけです。
コードを短く書くために、幾つか小技を使っていますが、大筋はこんなに単純。
(???) 2017/01/12(木) 11:44
>>またこれは出来ればですが、見積有効期限が本日を過ぎていれば >>セルを塗りつぶしたいです。
えっ??
本日が見積もり有効期限を過ぎていれば ではないのですか??
(β) 2017/01/12(木) 12:00
勉強していますが、今回、Sheet1とSheet2を書かなくてもちゃんと動作している事が
不思議に感じます。
それとj+1行までコピーして、さらにセルの下側に罫線を書くのはなぜでしょう?
βさん、御指摘ありがとう御座います。その通りです。
(ふみ) 2017/01/12(木) 12:07
別案です。
処理方式としては ???さん提示のイベント処理、あるいは 11さん提示の ActiveXボタン起動もあるのですが 別案です。
ボタンはフォームツールのボタン。 そのボタンに、以下のマクロをマクロ登録します。
標準モジュールに書いて下さい。
Sub Test() Dim f As Range Dim r As Range Dim sht As Worksheet
Set sht = Sheets("Sheet1") Set f = Sheets("Sheet2").UsedRange.Columns(1).Find(What:=sht.Range("D3").Value, LookAt:=xlWhole) If f Is Nothing Then MsgBox "指定の図番は登録されていません" Exit Sub End If Set r = f.CurrentRegion If r.Row = 1 Then Set r = r.Offset(1).Resize(r.Rows.Count - 1)
With sht .Range("A1", .UsedRange).Offset(7).ClearContents .Range("F3").Value = r.Range("B1").Value .Range("H3").Value = r.Range("C1").Value With .Range("B8:G8").Resize(r.Rows.Count) .Value = r.Columns("D:I").Value With .EntireRow.Columns("G") .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=AND(G8<>"""",G8<TODAY())" .FormatConditions(1).Interior.Color = vbRed End With End With End With
End Sub
(β) 2017/01/12(木) 12:15
次に、With Sheets("Sheet2") と記述することで、End With まではオブジェクト名を省略した場合は、Sheet2 になります。自シートの場合と違い、頭にピリオドが付いている点に注意。.Range("A1") ならば、ThisWorkBook.Sheets("Sheet2").Range("A1") です。
なお、1行余分にコピーするのは、空欄を見つけた行までを対象にしたためです。罫線を引いてあるとは思わなかったので。 なので、j行までコピーしている箇所を、j-1行に変えてみてください。
(???) 2017/01/12(木) 12:21
でも、1件抽出毎に色を付けても期限切れチェックには不十分なので、元データのI列で色を付けておくべきかと思いますよ。
(???) 2017/01/12(木) 12:55
それでも頭が悪いので、なぜうまくSheet2からSheet1のセルにコピー出来るのか
理解出来ませんが、お許し下さい。
それと罫線は自分で書いてました。申し訳有りません。j-1で解決しました。
あと、期限切れは仰る通りと思います。データベースの方で定期的に期限切れの見積を
取り直す様にします。
βさん、ありがとう御座います。
ボタン起動や有効期限切れで色付けなど、出来れば、のところまで対応ありがとう御座います。
ただ、図番が空白の時にメッセージを出さずに違う図番で続行したり、期限を過ぎていても
色をつけてくれないなど、バグがある様に思います。
もし直して頂けるのなら、???さんが仰る通りSheet2の期限をチェック頂けるとありがたいです。
Sheet1の方の罫線を消さずに転記してくれて、とてもいいなと思っているので、
よろしくお願い致します
(ふみ) 2017/01/12(木) 13:12
.Range(.Cells(i, "D"), .Cells(j - 1, "I")).Copy Range("B8")
私のコード中のこの部分を、
.Range(.Cells(i, "D"), .Cells(j - 1, "I")).Copy Range("B8").PasteSpecial xlPasteValues
こう変えてみてください。
(???) 2017/01/12(木) 14:06
値だけコピー出来る様になりました。
あと、終わり方の体裁だけの事なのですが、
Sheets("Sheet2").Activate
Application.CutCopyMode = False
Sheets("Sheet1").Activate
Range("A1").Activate
も追加させて頂きました。
(ふみ) 2017/01/12(木) 14:36
>>図番が空白の時にメッセージを出さずに違う図番で続行したり、
はい、そうですね。 わざわざ図番を空白にしてボタンをおすという操作をするとは思わなかったので。 そういうことを想定するなら、Findメソッドの前に
If IsEmpty(sht.Range("D3")) Then MsgBox "図番を指定してください" Exit Sub End Sub
といったものを加えておけばいかがですか?
>>期限を過ぎていても 色をつけてくれないなど、バグがある様に思います。
具体的には、今日実行したとして、どんな日付で、色がつくべきところ、色なしになったのですか?
(β) 2017/01/12(木) 15:07
もしかして 色を付けたかったのは SHeet2 のほうですか?
もし、そうであれば SHeet2 の I列に条件付書式をセットしておけばいかがでしょう。
(β) 2017/01/12(木) 15:11
If IsEmpty(sht.Range("D3")) Then
MsgBox "図番を指定してください" Exit Sub End If
で問題を回避出来ました。
空白でボタンを押しても何も表示されなければ問題は無かったのですが、ある図番のデータを表示したので、
これは間違える可能性があると思いました。
期限については2016/12/31と書いて実行したのですが、色がつきませんでした。
おそらくβさんの方で検証されて問題がなかったのだと思いますが、
この日付の書き方が問題でしょうか?
よろしくお願い致します。
追記
色をつけたかったのは、元々はSheet1の方です。
???さんに御指摘を頂いて、データベースの方にするべきだと思い、βさんがコードを直して頂けるのなら、
Sheet2の方にして欲しいと途中でお願いを変更しています。
なのでSheet2のI列に条件付書式をセット致します。
(ふみ) 2017/01/12(木) 15:31
全く理由がわかりませんが、
If IsEmpty(sht.Range("D3")) Then
MsgBox "図番を指定してください" Exit Sub End If
を
If IsEmpty(sht.Range("D3")) Then
MsgBox "図番を指定してください" With sht .Range("A1", .UsedRange).Offset(7).ClearContents End With Exit Sub End If
に書き換えたところ、
.Value = r.Columns("D:I").Value
のところでG列の最後の行(日付が書いていないところ)を赤色で塗る様になりました。
(ふみ) 2017/01/12(木) 15:54
処理の最初に転記領域をクリアし、G列の条件付書式を削除しましょう。 (アップ後、ちょこって訂正 16:51)
Sub Test() Dim f As Range Dim r As Range Dim sht As Worksheet
Set sht = Sheets("Sheet1")
With sht .Columns("G").FormatConditions.Delete .Range("A1", .UsedRange).Offset(7).ClearContents .Range("F3").ClearContents .Range("H3").ClearContents If IsEmpty(.Range("D3")) Then MsgBox "図番を指定してください" Exit Sub End If End With
Set f = Sheets("Sheet2").UsedRange.Columns(1).Find(What:=sht.Range("D3").Value, LookAt:=xlWhole) If f Is Nothing Then MsgBox "指定の図番は登録されていません" Exit Sub End If Set r = f.CurrentRegion If r.Row = 1 Then Set r = r.Offset(1).Resize(r.Rows.Count - 1)
With sht .Range("F3").Value = r.Range("B1").Value .Range("H3").Value = r.Range("C1").Value With .Range("B8:G8").Resize(r.Rows.Count) .Value = r.Columns("D:I").Value With .EntireRow.Columns("G") .FormatConditions.Add Type:=xlExpression, Formula1:="=AND(G8<>"""",G8<TODAY())" .FormatConditions(1).Interior.Color = vbRed End With End With End With
End Sub
(β) 2017/01/12(木) 16:47
今日はもう時間切れなので、明日朝から確認致します。
(ふみ) 2017/01/12(木) 17:15
>>処理の最初に転記領域をクリアし、G列の条件付書式を削除しましょう。
よくわからなかったので、新しいブックにデータ部分だけをコピーし、
コードを貼り付けてやってみましたが、やはり色は塗ってくれません。
それ以外は全く問題無く動作します。
(ふみ) 2017/01/13(金) 08:35
これは
With sht .Columns("G").FormatConditions.Delete .Range("A1", .UsedRange).Offset(7).ClearContents .Range("F3").ClearContents .Range("H3").ClearContents
この事ですか?
βさんの方ではちゃんと色を塗りますか?
(ふみ) 2017/01/13(金) 08:44
コメントしているように、コードで色塗りしているのは Sheet1 であって Sheet2 に対しては、何もしていません。
>>やはり色は塗ってくれません。
Sheet1 で色塗りされなかったということですか? であれば、これもお願いしたように、
>>具体的には、今日実行したとして、どんな日付で、色がつくべきところ、色なしになったのですか?
これを教えてください。
Sheet2 に関しては、条件付き書式を設定しておく提案をして
>>なのでSheet2のI列に条件付書式をセット致します。
というレスで、そちらで設定されたのかと思っているんですが。
念のため、設定は
・Sheet2 の I列を選択 ・条件付書式 数式が =AND(I1<>"",I1<TODAY()) で背景色を好きな色に。
もしかしたら、これを、処理のつど、毎回、マクロ内でやりたいということですか? であれば、この設定操作をマクロ記録すればコードができますので、それを組み込めばいかがでしょう?
(β) 2017/01/13(金) 08:48
解かっています。
>>具体的には、今日実行したとして、どんな日付で、色がつくべきところ、
色なしになったのですか?
昨日御連絡した通り、期限については2016/12/31と書いて実行したのですが、色がつきませんでした。
>>なのでSheet2のI列に条件付書式をセット致します。
???さんが書いてくれたコードのブックの方にはSheet1とSheet2の両方にセット済です。
βさんのブックの方はコードでSheet1の方に色が塗れる様に書いてくれているので待っている状態です。
(ふみ) 2017/01/13(金) 09:05
>>期限については2016/12/31と書いて実行したのですが、色がつきませんでした。
あぁ、すでにレスいただいてたんですね。見落としてました。
ところで、こちらで、最初に例示いただいたサンプルデータを使い、ABC-1234567 の イロハニ精機 分を 2016/12/31 に変更した上で、(β) 2017/01/12(木) 16:47 でアップしたコードを実行。
ちゃんと 2016/12/31 に色がついていますが????
(β) 2017/01/13(金) 09:12
それをお聞きしたかったのです。2回ほど質問しています。
こちらではアイウエオ製作所を2016/12/31に、岩谷産業を2017/1/10に変更してテストしていますが
色を塗りません。
唯一、2017/01/12(木) 15:54 のコメントの時にコードを変更した事によって見積有効期限欄の
日付を書いていない最下行に色を塗りましたと報告しましたが返事がありませんでした。
βさんはあまりこちらのコメントを正しく読んで頂けていない印象があります。
(ふみ) 2017/01/13(金) 09:29
>>βさんはあまりこちらのコメントを正しく読んで頂けていない印象があります。
そうかもしれませんね。 少なくとも、ほかの方々とふみさんのやりとりには、ほとんど目を通していません。 それに加えて、生来の粗忽ものですので、思いこみなんかは、やまほどあると思いますよ。
それにしても、回答をして、叱られたのは初めてですねぇ・・・・
Sheet1 に抽出した日付が今日を過ぎていれば色がつかない『はずがない』コードだと思っていますので 色がつかないと何度もいわれる、そのことが Sheet2 のことを言ってるんだろうなと、こちらはこちらで 思いこんでいました。
>>見積有効期限欄の 日付を書いていない最下行に色を塗りましたと報告しましたが返事がありませんでした。
これについては、そちらの Sheet2 のデータ、特に空白セルに見えるところの値によっては、いったんセット済みの 条件付き書式が、前回より抽出行数が少ない場合に悪さをすることもあるなぁということで、
『 処理の最初に転記領域をクリアし、G列の条件付書式を削除しましょう。』とレスして対応コードをアップしたつもりです。
いずれにしても、こちらではOK,そちらではNG ということは、どこかしら シートの状態で、理解のアンマッチがあるんだろうと思います。
★Sheet1,Sheet2 がある新規ブックに以下の TestGen と、(β) 2017/01/12(木) 16:47 でアップした Test を貼り付け TestGen を実行した後、Sheet1 の D3 に ABC-1234567 をいれて Testを実行してみてください。 色は塗られませんか???
Sub TestGen() With Sheets("Sheet2") .Cells.ClearContents .Range("A1:I1").Value = Array("図番", "名称", "数量", "区分", "取引先コード", "取引先名", "価格", "納期", "見積有効期限") .Range("A2:C2").Value = Array("ABC-1234567", "防着板1", 1) .Range("D2:I4").Value = "xxx" .Range("I2").Value = "2017/3/31" .Range("I3").Value = "2016/12/31" .Range("I4").Value = "2017/1/10" End With End Sub
(β) 2017/01/13(金) 12:00
新しいブックにTestGenとTestをやってみましたが、やはり色は塗られません。
期待してやってみたのですが、残念です。
他に考えられる原因はありますか?
叱ったのではありません。先生を叱るはずがありません。
真剣に相談しているのに、と不満を感じてしまいました。
(ふみ) 2017/01/13(金) 12:44
>>やはり色は塗られません。
お手上げですねぇ。
先ほどレスした時点では 自宅PCで確認後アップしたわけですが、今、場所を移して まったく別の環境(近所の病院のPCルーム)で、新規ブックに TestGen と Test を貼りつけて実行。 ここでも、ちゃんと Sheet1 の 2016/12/31 と 2017/1/10 に色が塗られます。
これが新規ブックではなく、既存ブックで、そのシートに対してなにがしかの設定があるということなら 考えられるところもあるかもしれませんが、新規ブックですからねぇ。 条件は、こちらとまったく同じはずです。
たとえば、新規ブックでテストしてもらった Sheet1 の I8 に =AND(G8<>"",G8<TODAY()) これを 下に I10 までフィルコピーすると、3つのセル、False True True にはなりませんか?
(β) 2017/01/13(金) 13:15
>>他に考えられる原因はありますか?
コメントしたように、今のところ思いつきません。
そんなことは絶対にないと思いますが、あえて 可能性 ということなら PC日付がくるっている?
ただ、こちらで確認している環境は xl2010とxl2013。 xl2007は無いので確認できないのですが、それでも、このコードであれば バージョンの違いはありえないとおもいますし・・・・
(β) 2017/01/13(金) 13:26
なりました。これはなりましたが色は塗られません。
長々とありがとう御座いました。諦めます。
というか、条件付書式をセットすれば良いだけなのに、なぜ色が塗られないのか、
こだわってしまいました。申し訳有りません。
ありがとう御座いました。
(ふみ) 2017/01/13(金) 16:25
もう一度と思い、その後2回、走らせてみましたが、2回とも色は塗られませんでした。
私のPC自身に問題があるのかも知れません。
(ふみ) 2017/01/13(金) 16:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.