[[20161206092204]]　『空白＆「/」』（師走）　ページの最後に飛ぶ

『空白＆「/」』（師走）

 お世話になります。
 退職された方が作った物でマクロが組み込んであります。
 私はマクロ記録しかわからないので、お知恵お願いいたします。

 ・トラックのNoプレ－ト
    32-45あるいは43-65を選択したら空白
    それ以外なら「/」が入る。

 ・1年分のシ－トなので納入先の変動で毎日、配車が変わります。
   範囲は
   トラックのNoプレ－トはC7～
   空白または「/」はN7～

 宜しくお願い致します。

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

 その説明は現在のマクロがそうなっているということなのか？
 それとも現在のマクロにそういった機能を追加したいということなのだろうか？

 何を質問したいのかを具体的に書いてくれ。
（ねむねむ） 2016/12/06(火) 09:27

 処理対象のシートのレイアウトを具体的に説明いただくと要件も理解しやすいのですが
 往々にして、その説明が不足していて、そのためのＱ／Ａが続く場合がありますので、まずは　現在のコードを
 そのまま（抜粋せず、また手打ちせず）コピペでアップしてみたらどうでしょうか。

（β） 2016/12/06(火) 09:31

 ねむねむさん、βさん
 ありがとうございます。質問が不足していようですいません。

 ブック内の
 A社、B社、C社の3つのシ－トにトラックのNoプレ－トを入力しております。
 例
 A社のシ－ト
 C7に12-34を選択したらN7に「/」が入るように
 C7に32-45あるいは43-65を選択したらN7は空白

 現在入っているコ－ドですが
This Workbook(30分で閉じる)に

Option Explicit

 '====================================================================================
 Const e_tm = "終了時刻"
 '====================================================================================
 Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.OnTime EarliestTime:=get_cdp(e_tm).Value, Procedure:="thisworkbook.end_proc", Schedule:=False
    On Error GoTo 0
 End Sub
 '====================================================================================
 Private Sub Workbook_Open()
    Dim tm As Date
    tm = Now() + TimeValue("00:30:00")
    If mk_cdp(e_tm, msoPropertyTypeDate, tm) <> 0 Then
       get_cdp(e_tm).Value = tm
    End If
    Application.OnTime EarliestTime:=get_cdp(e_tm).Value, Procedure:="thisworkbook.end_proc"
    Sheets("変更・追加").Protect UserInterfaceOnly:=True
 End Sub
 '====================================================================================
 Sub end_proc()
    ThisWorkbook.Close True
 End Sub
 '======================================================================
 Function mk_cdp(pnm As Variant, mytype As MsoDocProperties, myvalue)
    On Error Resume Next
    With ThisWorkbook
       .CustomDocumentProperties.Add pnm, False, mytype, myvalue
    End With
    mk_cdp = Err.Number
    On Error GoTo 0
 End Function
 '======================================================================
 Function get_cdp(pnm As String) As DocumentProperty
    Dim cp As DocumentProperty
    Set get_cdp = Nothing
    For Each cp In ThisWorkbook.CustomDocumentProperties
      If cp.Name = pnm Then
          Set get_cdp = cp
          Exit For
          End If
      Next
 End Function

 変更・追加のシ－ト(レ点)に
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

 If (Target.Rows.Count <> 1) Or (Target.Columns.Count <> 1) Then Exit Sub
       If Intersect(Range("H6:H5000,J6:J5000,M6:M5000"), Target) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Target.Value = "" Then
        Target.Value = ChrW(9745)
    Else
        Target.Value = IIf(AscW(Target.Value) = 9745, ChrW(9744), ChrW(9745))
    End If
    Cancel = True
    Application.EnableEvents = True
 End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A6:M1000")) Is Nothing Then Exit Sub
    Dim r As Range
    Application.EnableEvents = False
    For Each r In Intersect(Target, Range("A6:M1000"))
        If IsDate(r.Value) = True Then r.Offset(, 1).Value = Time
        If r.Value = "" Then r.Offset(, 1).ClearContents
    Next
    Application.EnableEvents = True
 End Sub

Sub Auto_Open()

   Sheets("変更・追加").Protect UserInterfaceOnly:=True
 End Sub

 宜しくお願い致します。

（師走） 2016/12/06(火) 10:12

 このコード、すべて　ThisWorkbookモジュールに記載されているのですか？
 どう見ても　シートモジュールのコードや標準モジュールのコードが混在しているように見受けられますが。

 それと、 Private Sub Workbook_Open()　と　Sub Auto_Open()  なぜ、この２つが登場しているのでしょう？
 （何か意図があれば、だめということではないですが）

（β） 2016/12/06(火) 10:22

 βさん
 ごめんなさい。よくわからないです。
 私としては、コ－ピして貼り付けただけなので!

 ThisWorkbookモジュールには時間で閉じるコ－ドだけです。(たぶん)

 Sheet1(変更・追加) モジュールに
 レ点のコ－ドだと思います。

（師走） 2016/12/06(火) 10:37

 師走さんの書き込みで

 >This Workbook(30分で閉じる)に

 >変更・追加のシ－ト(レ点)に
 とどこにあるかが書かれているように思えるが。

 もっとも
 >Sub Auto_Open() 
 はワークシートモジュールではなく標準モジュールではないかと思うが。
（ねむねむ） 2016/12/06(火) 10:51

 ねむねむさん
 ありがとうございます。

 Sub Auto_Open()
 もSheet1(変更・追加) モジュールにかかれています。
 必要ないのでしょうか???

（師走） 2016/12/06(火) 11:06

 Sub Auto_Open()
 これがワークシートモジュールにあるとすると、そのシート上のボタンか何かでそのマクロが呼び出されているのだろうか？

 もし、どこからも呼び出されていない場合、そのプロシージャは何の働きもしていないことになる。

 通常Auto_Openという名前のプロシージャは標準モジュールに作成することでブックが開かれた際に自動実行されるようになっている。
 (ThisWorkbooモジュールのWorkbook_Open()と同じような機能)

（ねむねむ） 2016/12/06(火) 11:17

 ねむねむさん
 説明ありがとうございます。
 ボタンはないです。
 必要なさそうですね。
 ありがとうございます。

 浅はかな考えなのですが(お叱りの言葉を受けるかも)
 例えば
 A社のシートモジュールに
 C7:C1000にトラックのNoプレ－ト
 32-45あるいは43-65を選択したら
 N7:N1000に空白
 C7:C1000にトラックのNoプレ－ト
 32-45・43-65以外を選択したら
 N7:N1000に「/」が入る。

 横展開で
 B社のシートモジュールとC社のシートモジュールも同様

 どうなんでしょうか?

（師走） 2016/12/06(火) 11:35

 とりあえず、コードをざらっと流し読みをしてみました。

 ThisWorkbookモジュールに書かれている

 Private Sub Workbook_Open  と
 Private Sub Workbook_BeforeClose(Cancel As Boolean) および　そこで使われている
 end_proc、mk_cdp、get_cdp　の３つは、今回のテーマには関係しないので無視します。

 ただ、どこに書かれているかは不明ですが Auto_Open 、ここでやっていることは
 変更・追加　という名前の保護されたシートに対してマクロからは処理できるような設定をしているだけで
 かつ、この処理は Workbook_Open でも実行されていますので、Ayto_Open は不要です。
 消しておかれることを推奨します。

 アップされたコードがすべてであれば、どこにも、この　変更・追加　シートにマクロから書きこんでいる
 部分がないので、なんのための処理なのかは見当がつきませんが、今回のテーマとは関係ない（と思われる）
 ので、深く考えないことにします。

 で、残りのコード、
 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)  と
 Private Sub Worksheet_Change(ByVal Target As Range) ですけど、これらは A社、B社、C社の
 それぞれのシートモジュールに同じものが書かれているんでしょうね。（推測ｄす）
 もし、これらのコードが　変更・追加シートのシートモジュールに書かれているとすれば、以下のコメントは
 間違ったコメントになります。

 これらのコードでしていることは

 H6:H5000,J6:J5000,M6:M5000　の範囲内で、単一セルの右クリック選択があった時、そのセルにレ点を付けたり
 レ点を消したりしています。

 また、A6:M1000　の範囲内に日付型のデータが入力されたら、その右横のセルに現在時刻をセット。
 その範囲内の入力が空白なら　その右横のセルもクリア。日付型、空白　いずれでもない　通常の入力なら何もしていません。

 で、今回のテーマ、現在の機能に「つけくわえる」のですね？
 横展開というのは A社でもB社でもC社でも、そういったことをしたいということですね。

 この理解に基づいてコードを書いて、書き上げたらアップしますが、違っていれば、早めに、違うと　言ってくださいね。

（β） 2016/12/06(火) 14:45

 ↑の回答をもらって居ない状態で見切り発車ですので、一抹の不安はありますが。
 今回の手当ては Changeイベントの見ですので、BefreRightClick は今のままでもいいのですが
 １つのシートに対する処理が、シートモジュールとThisWorkbookモジュールに混在するのは
 好ましくないので ThisWorkbookモジュールに一本化します。

 ただ、シートに対する処理は　入力、右クリックの既存処理が２つ、あたらしい入力処理が１つ。
 都合、３つの処理になりますが、それぞれの処理で相手にしている対象領域が、重なっているというところに
 違和感を覚えます。

 ●現在の A社、B社、C社の　各シートモジュールの

 Worksheet_BeforeRightClick プロシジャと　Worksheet_Change　プロシジャを　すべて消してください。
 で、 ThisWorkbookモジュールに以下を追加してください。
 対象のシート名は　★印で判定（２か所）していますので、ここは実際のものに直してください。

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

    Select Case Sh.Name
        Case "A社", "B社", "C社"    '★対象シート名

            '既存の処理部分
            Set a = Intersect(Target, Range("A6:M1000"))
            If Not a Is Nothing Then
                Application.EnableEvents = False
                For Each r In a
                    If IsDate(r.Value) = True Then r.Offset(, 1).Value = Time
                    If r.Value = "" Then r.Offset(, 1).ClearContents
                Next
                Application.EnableEvents = True
            End If

            '今回の追加部分
            Set a = Intersect(Target, Range("C7:C1000"))
            If Not a Is Nothing Then
                Application.EnableEvents = False
                For Each r In a
                    Select Case r.Value
                        Case "32-45", "43-65"
                            r.EntireRow.Columns("N").ClearContents
                        Case Else
                            r.EntireRow.Columns("N").Value = "/"
                    End Select
                Next
                Application.EnableEvents = True
            End If

    End Select
 End Sub

 Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

    If Target.Count <> 1 Then Exit Sub
    If Intersect(Range("H6:H5000,J6:J5000,M6:M5000"), Target) Is Nothing Then Exit Sub

    Select Case Sh.Name
        Case "A社", "B社", "C社"    '★対象シート名

            Application.EnableEvents = False
            If Target.Value = "" Then
                Target.Value = ChrW(9745)
            Else
                Target.Value = IIf(AscW(Target.Value) = 9745, ChrW(9744), ChrW(9745))
            End If
            Cancel = True
            Application.EnableEvents = True

    End Select

 End Sub

（β） 2016/12/06(火) 15:20

 βさん
 お返事が遅くなり申し訳ないです。

 今、お家なので
 わかる範囲でお答えさせていただきますね。

 >Ayto_Open は不要です。
 消しておかれることを推奨します。

 明日消しますね。

 >A社、B社、C社の
 それぞれのシートモジュールに同じものが書かれているんでしょうね。

 A社、B社、C社の
 それぞれのシートモジュールには、何も書いてありません。

 >横展開というのは A社でもB社でもC社でも、そういったことをしたいということですね。

 その通りです。

 早くお返事をすればよかったのですが
 コードの作成
 心から感謝と申し訳なさが混同しております。

（師走） 2016/12/06(火) 18:49

 >>A社、B社、C社の
 >>それぞれのシートモジュールには、何も書いてありません。

えっ！！

 では、アップされた

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

と

 Private Sub Worksheet_Change(ByVal Target As Range)

 は、どこに書いてあるんですか？？

（β） 2016/12/06(火) 19:17

 βさん
 お返事ありがとうございます。
 恐縮しております。

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 と
 Private Sub Worksheet_Change(ByVal Target As Range)

 は
 Sheet1(変更・追加) モジュールにかいてあります。

（師走） 2016/12/06(火) 19:26

 書き込んであるコードを区切って
 コピペしたほうがよかったかもしれませんね。
 βさんを悩まさせて
 ごめんなさい。
（師走） 2016/12/06(火) 19:31

 であれば、アップしたものは、いったん　忘れてください。
 つまり　Sheet1(変更・追加) モジュール　は、そのままにして、
 THisWorkbookモジュールに追加するのは以下のみです。

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

    Select Case Sh.Name
        Case "A社", "B社", "C社"    '★対象シート名

            Set a = Intersect(Target, Range("C7:C1000"))
            If Not a Is Nothing Then
                Application.EnableEvents = False
                For Each r In a
                    Select Case r.Value
                        Case "32-45", "43-65"
                            r.EntireRow.Columns("N").ClearContents
                        Case Else
                            r.EntireRow.Columns("N").Value = "/"
                    End Select
                Next
                Application.EnableEvents = True
            End If

    End Select
 End Sub

（β） 2016/12/06(火) 20:56

 βさん
 再度作っていただきましてありがとうございますね。
 明日
 早々に社にて使わせてもらいます。
 明日
 お返事させてもらいます。

 おやすみなさいませ。
（師走） 2016/12/06(火) 21:27

 βさん
 おはようございます。

 思った通りの動作はしてくれるのですが
 例えば
 C7にトラックのNoプレ－ト「12-34」を選択するとN7に「/」が入るのはよいのですが
 間違って
 その日の納入トラックがないのに気付いてC7を空白にしても「/」は残ってしまいます。
 また
 最初にC7の空白を選択しても「/」が出てしまいます。

 C7:C1000が空白の場合、「/」が出ないようお願いできないでしょうか
 宜しくお願い致します。

（師走） 2016/12/07(水) 09:23

 Case "32-45", "43-65"

 これを

 Case "32-45", "43-65", Empty

 に変えてください。

（β） 2016/12/07(水) 09:31

 βさん
 早々の対応ありがとうございます。

 βさんのお力沿いにて
 やったと笑みがこぼれてしまいました私です。
 今後とも宜しくお願い致しますね。

 無知な私から感謝をこめて!
 風邪などひかないように自愛くださいませ。

（師走） 2016/12/07(水) 09:46

コメント返信：

[ 一覧(最新更新順) ]

[[20161206092204]] 『空白＆「/」』（師走） ページの最後に飛ぶ

[[20161206092204]]　『空白＆「/」』（師走）　ページの最後に飛ぶ