[[20130322113443]]　『マクロで入力規則』（4949）　ページの最後に飛ぶ

『マクロで入力規則』（4949）

 WindowsXP　Excel2003

 　　Ｂ列　　Ｃ列　　  Ｄ列　  Ｅ列
 2　 記号 　 品名	　  単位	　単価
 3
 4
 　
 Ｂ3セルにＡと入力すると、Ｃ3にみかん　Ｄ3に個　Ｅ3に100
 Ｂ4セルにＢと入力すると、Ｃ4にりんご　Ｄ4に個　Ｅ4に80
 Ｂ5セルにＣと入力すると、Ｃ5にメロン　Ｄ5に個　Ｅ5に800

 と入力出来るようにしたいのですがVLOOK関数を使用すれば可能なのですが、
 行数が2000行くらいまでありかつ20シート同じようなシートを作成しなければ
 ならないので容量が大きくなりすぎると思いまして、
 マクロを使用したいのですが単価が月単位で変更になるので別シートに

 記号 　 品名	　  単位	　単価
 Ａ　　　みかん　　　　個　　　100
 Ｂ　　　りんご　　　　個　　　80
 Ｃ　　　メロン　　　　個　　　800
 　　　　　　　　・
 　　　　　　　　・
 と作成しそれを入力規則の名前の定義で作成し単価が変更になったらこちらを変更し
 入力規則を織り込んだマクロを作成したいのですがそのようなことは
 可能なのでしょうか？
 ご伝授お願いします。
 （4949）

 「入力規則」ということだけど「選択候補のリスト」が必要？
 それとも、許されたものだけの入力を受け入れ、それいがいははじくだけでいいの？

 それと、月ごとの単価を設定しているシートのシート名と、入力する２０ぐらいのシートのシート名を
 区別するような、名前のルールを教えて。（対象シート名のルールであってもいいし、除外シート名のルールでもいい）

 (ぶらっと)

 とりあえずブック内のマスタのシート名は、先頭が"マスタ" ではじまっているものとして、
 そのほかのシートはすべて入力対象との前提。で、名前定義で登録してあるテーブル名を "PriceTable"としている。

 ThisWorkbookモジュールに

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim r As Range
    Dim c As Range
    Dim a As Variant

    If Sh.Name Like "マスタ*" Then Exit Sub
    Set r = Intersect(Target, Sh.Columns("B"))
    If r Is Nothing Then Exit Sub

    Application.EnableEvents = False

    For Each c In r
        If c.Row >= 3 Then
            c.Offset(, 1).Resize(, 3).Value = "#N/A"
            a = Application.Match(c.Value, Range("PriceTable").Columns(1), 0)
            If IsNumeric(a) Then
                c.Offset(, 1).Resize(, 3).Value = Range("PriceTable").Rows(a).Range("B1:D1").Value
            End If
        End If
    Next

    Application.EnableEvents = True

 End Sub

 (ぶらっと)

 ＞「入力規則」ということだけど「選択候補のリスト」が必要？
 必要です。
 記号のところは入力規則でAからHくらいまで選択をします。

 ＞月ごとの単価を設定しているシートのシート名
 は仕様10という感じです。

 シート名は10号から始まり35号くらいまであります。

 入力規則は号ごとに記号A,Bとかは同じですが品名が”キャベツ”になったり”のり”になったりと違うので

 名前定義は記号10～記号35という風に作成します。

 なのでThisWorkbookモジュールではなくシートモジュールに一つ一つマクロを組まないいけない
 様な気がします。
 （4949）

 >なのでThisWorkbookモジュールではなくシートモジュールに一つ一つマクロを組まないいけない
 >様な気がします。

 いやぁ、それってメンテナンスを考えても、避けたほうがいいね。シートごとに記述したとして
 所詮、このシートでは "名前35" とか このシートでは "名前10" とか、ハードコーディングするわけだから
 ThisWOrkbookモジュールで sh.Name から　それぞれの名前を特定してやればいいと思う。

 それより、

 >必要です。
 >記号のところは入力規則でAからHくらいまで選択をします。

 この意味は、セルの入力規則は、あらかじめ設定してあって、入力まではあくまで、それを使う。
 単に、デコードのみをマクロで行うということ？

 (ぶらっと)

 勘違いがあるかもしれないけど。
 ThisWorkBookモジュールで。
 コード内のシートとそれようの名前の紐つけは実際のものをいくつでも。

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim r As Range
    Dim c As Range
    Dim a As Variant
    Dim myName As String

    If Sh.Name Like "仕様*" Then Exit Sub
    Set r = Intersect(Target, Sh.Columns("B"))
    If r Is Nothing Then Exit Sub

    Select Case Sh.Name
        Case "データ10": myName = "記号10"
        Case "データ35": myName = "記号35"
    End Select

    If Len(myName) = 0 Then Exit Sub

    Application.EnableEvents = False

    For Each c In r
        If c.Row >= 3 Then
            c.Offset(, 1).Resize(, 3).ClearContents
            If Len(c.Value) > 0 Then
                a = Application.Match(c.Value, Range(myName).Columns(1), 0)
                If IsNumeric(a) Then
                    c.Offset(, 1).Resize(, 3).Value = Range(myName).Rows(a).Range("B1:D1").Value
                Else
                    c.Offset(, 1).Resize(, 3).Value = "#N/A"
                End If
            End If
        End If
    Next

    Application.EnableEvents = True

 End Sub

 (ぶらっと)

 ↑　先頭の　If Sh.Name Like "仕様*" Then Exit Sub　は、なくてもいいね。（もちろん、あってもいいけど）

 (ぶらっと)

 　　Ｂ列　　Ｃ列　　 Ｄ列　  Ｅ列　　  Ｆ列
 2　 記号 　 品名　　個数　   単位　 　単価
 3
 4

 という形でＤ列には入荷個数を手入力で入れる列が抜けてました。そのためＢ列にＡと入れた場合
 ＣＥＦ列は 入力されＤ列は空欄のままが理想なのです。
 削除の場合Ｂ列で削除行うと
 c.Offset(, 1).Resize(, 3).ClearContentsの3を4にしましたが手入力のＤ列まで
 消えてしまうので加工が必要と思うのですがマクロの内容が理解できないため解説をお願いします。

 　　　　　　　 If Len(c.Value) > 0 Then
               　　 a = Application.Match(c.Value, Range(myName).Columns(1), 0)
               　　 If IsNumeric(a) Then
                    c.Offset(, 1).Resize(, 3).Value = Range(myName).Rows(a).Range("B1:D1").Value
                Else
                    c.Offset(, 1).Resize(, 3).Value = "#N/A"
                End If
 上記の解説をお願いします。
 （4949）

 解説といっても、

 c.Offset(行,列) は　基準のセル（c）から下に何行、右に何列動かした場所という意味で
 c.Offset(, 1) は 同じ行の C 列　という意味。
 で、Resize(行,列)は、その領域（今回の場合は C●　という１セル）の大きさを指定行数分、指定列数分に設定するということ。
 だから、Resize(, 3)　は、右に列を３列にするということになり、c●:E●　という領域になる。

 で、アップしたコードは、コード数を減少させる（のみならず、実行効率アップ）ため１行にしているんだけど、
 連続した領域ではないということであれば、分けざるを得ないね。

 c.Offset(, 1).Resize(, 3).ClearContents　これを

c.Offset(, 1).ClearContents 'C列
c.Offset(, 3).Resize(, 2).ClearContents 'E,F列

 c.Offset(, 1).Resize(, 3).Value = Range(myName).Rows(a).Range("B1:D1").Value　これを

c.Offset(, 1).Value = Range(myName).Rows(a).Range("B1").Value
c.Offset(, 3).Resize(, 2).Value = Range(myName).Rows(a).Range("C1:D1").Value

 c.Offset(, 1).Resize(, 3).Value = "#N/A"　これを

c.Offset(, 1).Value = "#N/A"
c.Offset(, 3).Resize(, 2).Value = "#N/A"

 (ぶらっと)

 Set r = Intersect(Target, Sh.Columns("B"))

 For Each c In r
        If c.Row >= 3 Then

 これはＢ3から始まりという意味ですよね？
 Ｅ7から始めるとなると
 Set r = Intersect(Target, Sh.Columns("E"))

 For Each c In r
        If c.Row >= 7 Then

 と単純にはいかないのですか？

 理解が出来てないので・・・申し訳ないですけど教えてください。
 （4949）

 まず、Ｄ列に個数がはいったことによる対応をアップしたけど、それは確かめてくれた？
 １っ歩ずつやろうね。

 で、

 >と単純にはいかないのですか？

 ということだけど、その意図は？　直してみたけどうまくいかなかったということ？
 ただし、そちらがアップしたコードは、A とか B とか C といった入力を E列の 7行目以降に入力するように
 レイアウトをかえたということだけど、そうなの？
 どうも、唐突に E列がでてきても、困ってしまうんだけど？。

 それとも、Ｄ列に別のものが入るレイアウトになり、以前のＤ列がＥ列に、Ｅ列がＦ列になったことに対する
 対応を　Set r = Intersect(Target, Sh.Columns("E"))　等でやろうとしている？
 もし、そうなら、勘違いだよ。それでは、できない。

 追記）あっ、もしかしたら、レイアウトとしては、入力欄が E列7行目以降になった。
 　　　で、アップしたような改訂を行った。でも、なんだかうまくいかないということ？
 　　　もしそうなら、それはそれで、具合悪いかもね。
 　　　E列に入力するとして、マッチング結果をセットする場所はどこの列？
 　　　そこも正しくしなきゃね。

 (ぶらっと)

 D列に個数が入ったマクロはきちんと起動しました。
 ありがとうございました。
 しかし、日付などを入れる枠を設け忘れてたのでA,B,C,Dに余裕を持たせて且つ、行にも余裕を持たせようと思いまして以前のB3始まりをE7から始めようと思いまして。。。
 自分なりに変更などをしてましたが理解してないのでうまくいかず質問させていただきました。
 E7から始まり
     Ｅ列　　Ｆ列　　G列　　　H列　　　I列

 6　 記号 　 品名　　個数　   単位　 　単価
 7
 8
 G列の個数は手入力です。
 （4949）

 自分なりにやってみましたがやはり無理でした。
 ご伝授ください。
 （4949）

 上のほうで連絡した修正（不連続セル対応）に加えて、入力領域のチェックをE列の7行目以降とすればいいんだけど。

 以下の２か所の★マークが入力領域チェックの場所変更対応。

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim r As Range
    Dim c As Range
    Dim a As Variant
    Dim myName As String

    If Sh.Name Like "仕様*" Then Exit Sub
    Set r = Intersect(Target, Sh.Columns("E"))      '★
    If r Is Nothing Then Exit Sub

    Select Case Sh.Name
        Case "データ10": myName = "記号10"
        Case "データ35": myName = "記号35"
    End Select

    If Len(myName) = 0 Then Exit Sub

    Application.EnableEvents = False

    For Each c In r
        If c.Row >= 7 Then                          '★
            c.Offset(, 1).ClearContents 'F列
            c.Offset(, 3).Resize(, 2).ClearContents 'H,I列
            If Len(c.Value) > 0 Then
                a = Application.Match(c.Value, Range(myName).Columns(1), 0)
                If IsNumeric(a) Then
                    c.Offset(, 1).Value = Range(myName).Rows(a).Range("B1").Value
                    c.Offset(, 3).Resize(, 2).Value = Range(myName).Rows(a).Range("C1:D1").Value
                Else
                    c.Offset(, 1).Value = "#N/A"
                    c.Offset(, 3).Resize(, 2).Value = "#N/A"

                End If
            End If
        End If
    Next

    Application.EnableEvents = True

 End Sub

 (ぶらっと)

 出来ました。

 ぶらっとさんありがとうございました。
 （4949）

コメント返信：

[ 一覧(最新更新順) ]

[[20130322113443]] 『マクロで入力規則』（4949） ページの最後に飛ぶ

[[20130322113443]]　『マクロで入力規則』（4949）　ページの最後に飛ぶ