[[20170112090334]]　『検索』（ふみ）　ページの最後に飛ぶ

『検索』（ふみ）

　　A　　　　　　　　　　B　　　C　　　D　　　E　　　　　　　　F　　　　　　　　　　G　　　　H　　　　　　　I
1　　図番　　　　　　名称　　数量　区分　取引先コード　取引先名　価格　納期　　　　　見積有効期限
2　　ABC-1234567 防着板１　 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にデータベースとして、上の様な表を作ります。

ＡＢＣは一つだけですが、ＡＢＣに対して複数の取引先をデータベースとして
登録するので、Ｄ～Ｉは何行になるかわかりません。
この例では区切として５行目を空けて、６行目から次の図番を記入しています。

Sheet1のＤ３セルに図番を記入してボタンを押すと、Sheet2に同じ図番が
記入されていれば、Sheet1のＦ３セルに名称、Ｈ３セルに数量、
Ｂ８セルに区分、Ｃ８セル　取引先コード、Ｄ８セル　取引先名、
Ｅ８セル　価格、Ｆ８セル　納期、Ｇ８セル　見積有効期限、　を
転記させたいです。

そして取引先が複数あれば、Ｂ９～Ｇ９以降の次の行へ転記させたいです。
同じ図番がなければ「登録されていない図番です」のメッセージを出したいです。

取引先数が不確定の為、コードをどう書いて良いかわかりません。
またこれは出来ればですが、見積有効期限が本日を過ぎていれば
セルを塗りつぶしたいです。

細かいアレンジは自分で出来ると思いますが、基本となるコードを
教えて下さい。よろしくお願い致します。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

よく解らないですけど
Aの図版を全部入力して
フィルター抽出すれば良い
と思いますが
（１１） 2017/01/12(木) 10:44

Private Sub CommandButton1_Click()
Dim rng As Range

 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

（１１） 2017/01/12(木) 11:00

元データにオートフィルタするだけで十分に思いますねぇ。マクロで処理したいなら、まずは自分で調べて作ってみるのが筋というもの。たとえそれが1ヶ月かかろうとも。いきなり元となるコードを求めるのは丸投げと言って、褒められた行為ではありません。

とりあえず別案なぞ。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

１１さん、Sheet名を("Sheet2")に直してコードを走らせてみましたが、 Selection.AutoFilterのところで
エラー1004、RangeクラスのAutoFilterメソッドが失敗しました、になります。

？？？さん、いつもありがとう御座います。
丸投げと叱られるのを承知でお願いしてしまいました。
見事に動作しましたが、コードが難しくてこれから理解するのが大変と感じます。
アレンジする為には必要なので、勉強します。
ありがとう御座いました。

（ふみ） 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

今回のプロシジャは、Sheet1のシートモジュールです。なので、シートオブジェクトを省略した場合は、Sheet1になります。Range("A1")ならば、ThisWorkBook.Sheets("Sheet1").Range("A1") ということ。

次に、With Sheets("Sheet2") と記述することで、End With まではオブジェクト名を省略した場合は、Sheet2 になります。自シートの場合と違い、頭にピリオドが付いている点に注意。.Range("A1") ならば、ThisWorkBook.Sheets("Sheet2").Range("A1") です。

なお、1行余分にコピーするのは、空欄を見つけた行までを対象にしたためです。罫線を引いてあるとは思わなかったので。なので、j行までコピーしている箇所を、j-1行に変えてみてください。
（???） 2017/01/12(木) 12:21

あと見積もり有効期限切れですが、Sheet1のG列全体に「=AND(G1<>"",G1<TODAY())」で塗るような条件付き書式を設定してはいかが？

でも、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のＩ列に条件付書式をセット致します。

（ふみ） 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

のところでＧ列の最後の行（日付が書いていないところ）を赤色で塗る様になりました。

（ふみ） 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

＞＞処理の最初に転記領域をクリアし、G列の条件付書式を削除しましょう。

これは

 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のＩ列に条件付書式をセット致します。

 というレスで、そちらで設定されたのかと思っているんですが。

 念のため、設定は

 ・Sheet2 の　I列を選択
 ・条件付書式　数式が　=AND(I1<>"",I1<TODAY())  で背景色を好きな色に。

 もしかしたら、これを、処理のつど、毎回、マクロ内でやりたいということですか？
 であれば、この設定操作をマクロ記録すればコードができますので、それを組み込めばいかがでしょう？

（β） 2017/01/13(金) 08:48

＞＞コメントしているように、コードで色塗りしているのは　Sheet1 であって Sheet2 に対しては、
何もしていません。

解かっています。

＞＞具体的には、今日実行したとして、どんな日付で、色がつくべきところ、
色なしになったのですか？

昨日御連絡した通り、期限については2016/12/31と書いて実行したのですが、色がつきませんでした。

＞＞なのでSheet2のＩ列に条件付書式をセット致します。

？？？さんが書いてくれたコードのブックの方には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

＞＞ちゃんと 2016/12/31 に色がついていますが？？？？

それをお聞きしたかったのです。２回ほど質問しています。

こちらではアイウエオ製作所を2016/12/31に、岩谷産業を2017/1/10に変更してテストしていますが
色を塗りません。

唯一、2017/01/12(木) 15:54 のコメントの時にコードを変更した事によって見積有効期限欄の
日付を書いていない最下行に色を塗りましたと報告しましたが返事がありませんでした。

βさんはあまりこちらのコメントを正しく読んで頂けていない印象があります。
（ふみ） 2017/01/13(金) 09:29

 >>βさんはあまりこちらのコメントを正しく読んで頂けていない印象があります。

 そうかもしれませんね。　少なくとも、ほかの方々とふみさんのやりとりには、ほとんど目を通していません。
 それに加えて、生来の粗忽ものですので、思いこみなんかは、やまほどあると思いますよ。

 それにしても、回答をして、叱られたのは初めてですねぇ・・・・

 Sheet1 に抽出した日付が今日を過ぎていれば色がつかない『はずがない』コードだと思っていますので
 色がつかないと何度もいわれる、そのことが Sheet2 のことを言ってるんだろうなと、こちらはこちらで
 思いこんでいました。

 >>見積有効期限欄の 日付を書いていない最下行に色を塗りましたと報告しましたが返事がありませんでした。

 これについては、そちらの Sheet2 のデータ、特に空白セルに見えるところの値によっては、いったんセット済みの
 条件付き書式が、前回より抽出行数が少ない場合に悪さをすることもあるなぁということで、

 『 処理の最初に転記領域をクリアし、G列の条件付書式を削除しましょう。』とレスして対応コードをアップしたつもりです。

 いずれにしても、こちらではＯＫ，そちらではＮＧ　ということは、どこかしら　シートの状態で、理解のアンマッチがあるんだろうと思います。

 ★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)
        .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

 >>やはり色は塗られません。

 お手上げですねぇ。

 先ほどレスした時点では　自宅ＰＣで確認後アップしたわけですが、今、場所を移して
 まったく別の環境（近所の病院のＰＣルーム）で、新規ブックに TestGen と Test を貼りつけて実行。
 ここでも、ちゃんと Sheet1 の　2016/12/31　と　2017/1/10　に色が塗られます。

 これが新規ブックではなく、既存ブックで、そのシートに対してなにがしかの設定があるということなら
 考えられるところもあるかもしれませんが、新規ブックですからねぇ。
 条件は、こちらとまったく同じはずです。

 たとえば、新規ブックでテストしてもらった Sheet1 の I8 に　=AND(G8<>"",G8<TODAY())
 これを 下に I10 までフィルコピーすると、３つのセル、False True True にはなりませんか？

（β） 2017/01/13(金) 13:15

 >>他に考えられる原因はありますか？

 コメントしたように、今のところ思いつきません。

 そんなことは絶対にないと思いますが、あえて　可能性　ということなら　ＰＣ日付がくるっている？

 ただ、こちらで確認している環境は xl2010とxl2013。
 xl2007は無いので確認できないのですが、それでも、このコードであれば
 バージョンの違いはありえないとおもいますし・・・・

（β） 2017/01/13(金) 13:26

＞＞たとえば、新規ブックでテストしてもらった Sheet1 の I8 に　=AND(G8<>"",G8<TODAY())
＞＞これを下に I10 までフィルコピーすると、３つのセル、False True True にはなりませんか？

なりました。これはなりましたが色は塗られません。

長々とありがとう御座いました。諦めます。
というか、条件付書式をセットすれば良いだけなのに、なぜ色が塗られないのか、
こだわってしまいました。申し訳有りません。

ありがとう御座いました。
（ふみ） 2017/01/13(金) 16:25

ブックを閉じる前に、もう一度だけTestを走らせてみたら、なんと2017/1/10にだけ、
色が塗られました。

もう一度と思い、その後２回、走らせてみましたが、２回とも色は塗られませんでした。

私のＰＣ自身に問題があるのかも知れません。
（ふみ） 2017/01/13(金) 16:34

コメント返信：

[ 一覧(最新更新順) ]

[[20170112090334]] 『検索』（ふみ） ページの最後に飛ぶ

[[20170112090334]]　『検索』（ふみ）　ページの最後に飛ぶ