[[20130524131615]]　『エクセルでサジェスト機能』（ヒロ）　ページの最後に飛ぶ

『エクセルでサジェスト機能』（ヒロ）
エクセル2010です。
同じBOOK内にデータが入力させている”材料一覧”Sheetがあります。
作業シートSheet1（”入力”)があります。

”入力”のE18で頭文字を入力すると”材料一覧”のデータの中から候補を一覧で表示1つしかない場合はそのまま入力
と言う作業をしたい。（入力セルはE18～E35まで）

例：あいう材料・かきく材料・さしす材料・さしすせそ材料　と材料一覧シートのA：Aに入力されている。
入力シートのE18に　"あ"と入力すると"あいう材料"が入力される　"さし"と入力　　　するとプルダウンでさしす材料及びさしすせそ材料が入力候補として出てくる。　　　　Alt+↓で選択できる。

下記の記述で、問題が発生してます。
問題1　E18～E35までは一覧以外の文字は入力したくなく、入力規制をかけてほしい。
問題2　2つ以上選択肢がありプルダウンで入力候補が出てくるのですがそれを選んで選択すると、”材料一覧”SheetのA:Aまで選択肢のデータに置き換わってしまいます。

初心者です。なるべく分かりやすくお教え得ただけないでしょうか？

《標準モジュール》

 Sub 入力規則リスト(str As String, cSh As Worksheet)
    Dim buf As String, tmp As Variant
    Dim Sh As Worksheet
    Range("リスト").ClearContents
    buf = str
    tmp = Split(buf, ",")
    Set Sh = Worksheets("材料一覧")
    Sh.Activate
    Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)) = WorksheetFunction.Transpose(tmp)
    Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)).Name = "リスト"
    cSh.Activate
End Sub

Sub 入力候補表示(Sh As String, Rg As String, Tg As Range)

    Dim foundCell As Variant
    Dim listSheet As String '辞書のシート名
    Dim strDictionary As String '辞書の範囲
    Dim matchKey As String
    Dim strFormula As String ' 入力規則に入れる文字列
    Dim firstAddress As String ' 最初の結果のアドレス
    Dim matchWord As String
    Dim roopCount As Long
    Dim lngY As Long, intX As Long

    If Tg.Count > 1 Then Exit Sub

    ' アクティブセルの値が辞書に載っているか検索
    listSheet = Sh ' 検索対象シート

    strDictionary = Rg  ' 検索対象範囲

    matchKey = Tg.Value
    Set foundCell = Worksheets(listSheet).Range(strDictionary).Find(matchKey)

    ' 検索結果が空の場合終了
    If foundCell Is Nothing Then Exit Sub

    ' 検索結果を回す

    strFormula = ""
    roopCount = 0
    firstAddress = foundCell.Address
    Do
        ' 辞書から入力候補を収集
        lngY = foundCell.Cells.Row
        intX = foundCell.Cells.Column
        matchWord = Worksheets(listSheet).Cells(lngY, intX).Value

        '比較
        If InStr(matchWord, matchKey) > 0 Then
            strFormula = strFormula & matchWord & ","
        End If

        roopCount = roopCount + 1

        ' 次の入力候補へ
        Set foundCell = Worksheets(listSheet).Range(strDictionary).FindNext(foundCell)

    Loop While (Not foundCell Is Nothing) And (firstAddress <> foundCell.Address)

    ' 入力候補をセット
    Application.EnableEvents = False

    If roopCount = 1 Then
    '候補が一つの場合、それを入力

        If Tg = "" Then 'エラー処理
                Application.EnableEvents = True
                strFormula = ""
                Tg.Select
                Exit Sub
        Else
            Tg.Value = Left(strFormula, Len(strFormula) - 1)
        End If

    ElseIf Len(strFormula) > 0 Then

    'リストという名前の範囲を生成し配列を代入する
    Application.ScreenUpdating = False
    Call 入力規則リスト(strFormula, ActiveSheet)
    Application.ScreenUpdating = True
    '候補が複数ある場合は、候補のリストを表示
        On Error GoTo ErrorHandler
        With Tg.Validation '入力規則を設定
            .Delete
            .Add Type:=xlValidateList, Formula1:="=リスト"
            .ShowError = False
            .InCellDropdown = True
        End With
        Tg.Select
        SendKeys "%{DOWN}"
    End If

    Set foundCell = Nothing
    strFormula = ""
    Application.EnableEvents = True

ErrorHandler:

    Application.EnableEvents = True
    strFormula = ""
End Sub

《Sheet1（入力）》
Private Sub Worksheet_Change(ByVal target As Range)

    'DicSheetNameは辞書のシート名、
    'DicRangeAddressは辞書の範囲を指定する
    '
    Const DicSheetName = "材料一覧"
    Const DicRangeAddress = "A:A"

     If target.Count > 1 Then
     '選択セルが２つ以上は無効
         Set target = Nothing
         Exit Sub

     ElseIf Application.Intersect(target, Range("F18:E35")) Is Nothing Then
      '※入力セル以外の変更では無効(targetと共有するセル範囲がない）
         Exit Sub

     Else
     Call 入力候補表示(DicSheetName, DicRangeAddress, target)
     End If

End Sub

 コードはまだ精読していないけど質問。

 Sub 入力規則リスト　で、

 >Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)) = WorksheetFunction.Transpose(tmp)

 つまり、材料一覧のＡ列の値を書き換えているけど、これはなぜ？

 (ぶらっと)

 なんとなく想像も込めて、やりたいことって、こんなことかな？
 なお、

 >初心者です。なるべく分かりやすくお教え得ただけないでしょうか？

 以下のコードが、要件にマッチしていれば、あらためて、わかりにくいところをきいてくれれば解説するね。

 (シートモジュール）

 Private Sub Worksheet_Change(ByVal target As Range)

    'DicSheetNameは辞書のシート名、
    'DicRangeAddressは辞書の範囲を指定する
    '
    Const DicSheetName = "材料一覧"
    Const DicRangeAddress = "A"

    '※入力セル以外の変更は無視
    If Intersect(target, Range("E18:E35")) Is Nothing Then Exit Sub

    If target.Count > 1 Then
        '選択セルが２つ以上は無効
        MsgBox "複数セル同時変更はサポートしません" & vbLf & "入力を取消し元に戻します"
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
        Exit Sub
    End If

    Application.EnableEvents = False
    If Not 入力候補表示(DicSheetName, DicRangeAddress, target) Then
        MsgBox "リストにない値の入力は無効です" & vbLf & "入力を取消し元に戻します"
        Application.Undo

    End If

    Application.EnableEvents = True

 End Sub

 (標準モジュール）

 Function 入力候補表示(Sh As String, Rg As String, Tg As Range) As Boolean
    Dim c As Range
    Dim v() As String
    Dim k As Long

    If Len(Tg.Value) = 0 Then   'クリア
        Tg.Validation.Delete
        入力候補表示 = True             'OK
        Exit Function
    End If

    With Sheets(Sh)
        With .Range(Rg & "1", .Range(Rg & .Rows.Count).End(xlUp))
            ReDim v(1 To .Count)
            For Each c In .Cells
                If c.Value Like Tg.Value & "*" Then
                    k = k + 1
                    v(k) = c.Value
                End If
            Next
        End With
    End With

    If k = 0 Then Exit Function     'NG

    If k = 1 Then
        Tg.Validation.Delete
        Tg.Value = v(1)
    Else
        '入力規則のセット
        With Tg.Validation '入力規則を設定
            .Delete
            .Add Type:=xlValidateList, Formula1:=Join(v, ",")
            .ShowError = False
            .InCellDropdown = True
        End With
        Tg.Select
        SendKeys "%{DOWN}"
    End If

    入力候補表示 = True             'OK

 End Function

 (ぶらっと)

ぶらっと様
ありがとうございます。
やりたい事そのままでした。
本当に本当にありがとうございます。

コメント返信：

[ 一覧(最新更新順) ]

[[20130524131615]] 『エクセルでサジェスト機能』（ヒロ） ページの最後に飛ぶ

[[20130524131615]]　『エクセルでサジェスト機能』（ヒロ）　ページの最後に飛ぶ