ExcelVBA 入力規則のリストを追加するコード②

今教材研究に全く時間がさけないので，仕事上気づいた改善点をしばらく書くことになりそうです。

chemiphys.hateblo.jp

なんでも続ければいいと思ってる(;´▽｀A``

改善の様子を生暖かいまなざしで見ていただければ，同じ失敗をしないということで，

恥ずかしげもなく失敗談をします。(ﾟ▽ﾟ*)

前回のは，自分のあさはかさをよく知ることができ，なんだこれ，使いにくいと，改善を求めました。

原因は思い込みがかなりありました。

本当はデフォルトで，リストに無い値が入力されたら挿入される仕組みをExcelが持っててくれればいい。

のですが，そうではなさそう。もしそうなら，教えてください!

そして，リストに無い値ははねられるので，違う場所に追加したい言葉を入れる必要があるという思い込みが私にはありました。

その思い込みで作って運用していたので，違うことに初めて気づきました。

無効なデータが入力されたらエラーメッセージを表示する　このチェックを外しました。

外さなくても，注意や情報ってのを下のほうで選べばいいわけですが，

無効なデータが入力されたら，その値をリスト元に追加するかをマクロで聞かせるので，わたしはチェックを外しました。

　●あとは，無効なデータ・・・つまり，リスト元にないので，追加できるようにする。

　●間違って追加してしまい，元のデータをいじりに行くのはなんかもやっとするので，消せる仕組みも考える。

　●いろいろやっているうちに，空白がリスト元に入ったりするので，それも消したい。

欲張りだしたらきりがありませんが，まぁそれっぽくできました。なので，載せてみます。

Sheet1に入力する場所があります。

同じ列には同じ入力規則が入る前提。リスト ワークシートにはリスト元のデータが並んでいます。
リスト項目のとこにいらない＋が入ってるな・・ちょっと失敗している。

入力対象のシートのモジュールに下記のものを貼り付けます。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count <> 1 Then Exit Sub
    
    Dim 列文字列挙 As String, 列文字 As String, i As Long
    列文字列挙 = "B,C"
        
    For i = 0 To UBound(Split(列文字列挙, ","))
        列文字 = Split(列文字列挙, ",")(i)
        If AddressColumn(Target.Address) = 列文字 Then Call ValidationProc(Target)
    Next
    
End Sub

Function AddressColumn(StringAddress As String)
    If Mid(StringAddress, 3, 1) = "$" Then
        AddressColumn = Mid(StringAddress, 2, 1)
    Else
        AddressColumn = Mid(StringAddress, 2, 2)
    End If
End Function

Sub ValidationProc(TargetRange As Range)
    If TargetRange.Value = "" Then Exit Sub
    
    Dim listWorksheet As Worksheet
    Dim cellList As Range
    Dim cellVaridation As Range
    Dim validationFormula1 As String: validationFormula1 = TargetRange.Validation.Formula1
    
    If validationFormula1 = "" Then Exit Sub
    Set listWorksheet = Worksheets(Mid(validationFormula1, 2, InStr(validationFormula1, "!") - 2))
    Set cellList = listWorksheet.Range(Mid(validationFormula1, InStr(validationFormula1, "!") + 1))

    Dim C As Range, i As Long
    
    If WorksheetFunction.CountIf(cellList, TargetRange.Value) = 0 Then
        If Left(TargetRange.Value, 3) = "###" Then
            If MsgBox(Mid(TargetRange.Value, 4) & "をリスト項目から消しますか?", vbOKCancel) = vbCancel Then Exit Sub
            For Each C In cellList
                If C.Value = Mid(TargetRange.Value, 4) Then C.Delete
            Next
            TargetRange.ClearContents
        ElseIf MsgBox(TargetRange.Value & "を本当にリスト項目に追加しますか?", vbOKCancel) = vbOK Then
            cellList.Cells(1, 1).Offset(cellList.Rows.Count).Value = TargetRange.Value
            Set cellList = cellList.Resize(cellList.Rows.Count + 1)
        End If
        
        For i = cellList.Rows.Count To 1 Step -1
            If cellList.Cells(i, 1) = "" Then cellList.Cells(i, 1).Delete
        Next
        
        For Each C In TargetRange.EntireColumn.SpecialCells(xlCellTypeAllValidation)
            C.Validation.Delete
            C.Validation.Add xlValidateList, Formula1:="=" & listWorksheet.Name & "!" & cellList.Address
            C.Validation.ShowError = False
        Next
    End If
    
End Sub

列文字列挙　ってなんか日本語じゃないみたい(;´▽｀A``いい言葉が思いつかなかったんだ。

R1C1で普段やっていないので，やはり列は文字で示したい。

orがどんどん増えるのは，なんかいやなので，大好きなSplitに頼りました。

列文字列挙 = "B,C"

ここにマクロを動作させたい列のアルファベットを,区切りで追加すると，それらの列に対し，マクロが動作します。

リスト元に無いデータを入れたら，追加するか聞いてきます。

消したい項目がある場合は， ###に続けてそのリスト項目を入れると，消しますかと聞いてきます。

空白行は，リスト元をいじるときに消すようにしてみました。

いつも通り自分が使うためのものなので，動作保証はいたしません。

Validationプロパティ面白いですね。

Valueプロパティを使おうとしたときにいつも出てきて　イラッ(ﾟ▽ﾟ*)　としていた相手だったのにこんなに働き者だったとは。

とりあえず，リストを使うときにこうだったらいいなぁと思ってたものを曲がりなりにも実装できたので，自分的にはうれしい。

環境に合わない場合は適度に修正してください。

Rangeの中でCellという使い方もなんかいい。以前はOffsetとかでぐりぐりやってたので，やはり改善して何か書こうとすると，まがりなりにも成長できる気がします。

なので，今後もだらだらと何か書こうと思いますが，程度は低いので，万が一使われる場合は自己責任で!

使う様子をGIFアニメにしておきます。