自動入力セル - VBA

Question

ゴール

私は、3枚（私は1つで始めている）をループしたい列Cに、特定のタイプを探し、自動的に移入う列DのIn-cellドロップダウン（Data Validation設定にあるものに似ています）が自動的に挿入されます。In-cellドロップダウンでは、すべてのタイプの値がリストされますが、Typeに属する値でオートポピュレートする必要があります。

通報

以下のコード、すなわちタイプ1の、同じ値を持つすべてのセル内のドロップダウンリストを移入アイテム1 - アイテム2 - ITEM3 - ITEM4。

どのようにすべての値をリストするのか、同時にセルをオートポピュレートする方法はわかりません。

所望の出力

コード

簡単のため、私は以下のコードで二つの第一タイプを追加しました。

Sub AutoDropdown() 

Dim PersonSource As Range 
Dim PersonSourceTotal As Range 
Dim PersonCell As Range 
'Dim ws As Worksheet 

Dim i As Integer 
Dim lastRow As Integer 

Set PersonSourceTotal = Sheets("Sheet1").Range("D2:D200") 

With PersonSourceTotal.Offset(0, -2) 
    lastRow = .Cells(.Rows.Count, PersonSourceTotal.Columns.Count).End(xlUp).Row 
End With 

Set PersonSource = Sheets("sheet1").Range("D2:D" & lastRow) 

On Error Resume Next 

For Each PersonCell In PersonSource 
    Name = PersonCell.Offset(0, -3) 
    ID = PersonCell.Offset(0, -2) 
     If Name <> "" And ID <> "" Then 
      For i = 0 To lastRow 
       If PersonCell.Offset(i, -1) = "Type1" Then 
        arr1 = Array("Item1", "Item2", "Item3", "Item4") 
        arr1Merged = Join(arr1, "--") 
        With PersonCell.Validation 
               .Delete 
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ 
               Operator:=xlBetween, Formula1:=arr1Merged 
               .IgnoreBlank = True 
               .InCellDropdown = True 
               .InputTitle = "" 
               .ErrorTitle = "" 
               .InputMessage = "" 
               .ErrorMessage = "" 
               .ShowInput = True 
               .ShowError = True 
        End With 
       ElseIf PersonCell.Offset(i, -1) = "Type2" Then 
        arr2 = Array("Item5", "Item6", "Item7", "Item8", "Item9") 
        arr2Merged = Join(arr2, "--") 
        Debug.Print (arr2Merged) 
        With PersonCell.Validation 
               .Delete 
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ 
               Operator:=xlBetween, Formula1:=arr2Merged 
               .IgnoreBlank = True 
               .InCellDropdown = True 
               .InputTitle = "" 
               .ErrorTitle = "" 
               .InputMessage = "" 
               .ErrorMessage = "" 
               .ShowInput = True 
               .ShowError = True 
        End With 
       End If 
      Next i 
     Else 
      MsgBox "Remember to add Name and ID" 
     End If 
Next PersonCell 
End Sub 

Answer 1

EDIT：

あなたのコメントの後、私はより良いあなたの要件を反映しようとするコードを更新しました：

Sub AutoDropdown() 
Dim PersonSource As Range 
Dim PersonSourceTotal As Range 
Dim PersonCell As Range 
Dim i As Long 
Dim lastRow As Long 
Dim SelectionArray(1 To 4) As String 

Set PersonSourceTotal = Sheets("Sheet1").Range("D2:D200") 

With PersonSourceTotal.Offset(0, -2) 
    lastRow = .Cells(.Rows.Count, PersonSourceTotal.Columns.Count).End(xlUp).Row 
End With 

Set PersonSource = Sheets("Sheet1").Range("D2:D" & lastRow) 

arr1 = Array("Item1", "Item2", "Item3", "Item4") 'Define your selections items 
arr2 = Array("Item5", "Item6", "Item7", "Item8", "Item9") 
arr3 = Array("ItemE", "ItemF", "ItemG", "ItemH") 
arr4 = Array("ItemA", "ItemB", "ItemC", "ItemD") 

SelectionArray(1) = Join(arr1, "--") 'join the selections into another array 
SelectionArray(2) = Join(arr2, "--") 
SelectionArray(3) = Join(arr3, "--") 
SelectionArray(4) = Join(arr4, "--") 
AllSelections = Join(SelectionArray, ",") 'group all selections for data validation 
On Error Resume Next 

For Each PersonCell In PersonSource 
    VarName = PersonCell.Offset(0, -3) 
    ID = PersonCell.Offset(0, -2) 
     If VarName <> "" And ID <> "" Then 
      Select Case PersonCell.Offset(i, -1).Value 
       Case "Type1" 
        With PersonCell.Validation 
         .Delete 
         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections 
        End With 
        PersonCell.Value = SelectionArray(1) 
       Case "Type2" 
        With PersonCell.Validation 
         .Delete 
         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections 
        End With 
        PersonCell.Value = SelectionArray(2) 
       Case "Type3" 
        With PersonCell.Validation 
         .Delete 
         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections 
        End With 
        PersonCell.Value = SelectionArray(3) 
       Case "Type4" 
       With PersonCell.Validation 
         .Delete 
         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections 
        End With 
        PersonCell.Value = SelectionArray(4) 
       Case Else 
        MsgBox "No Type was entered on Column C" 
      End Select 
     Else 
      MsgBox "Remember to add VarName and ID" 
     End If 
Next PersonCell 
End Sub 

UPDATE：

を取得するには列Cの値（すなわち型番）が変更されたときに自動的に実行されるコードSheet1の下に次のコードを追加する必要があります。

Private Sub Worksheet_Change(ByVal Target As Range) 
If Target.Column = 3 Then AutoDropdown 'if a value is changed on Column 3/ Column C then call the name of the above subroutine, in this case it is called AutoDropdown 
End Sub