0

現在、Excel ワークブックにいくつかの VB コードがあります。これにより、データ検証 (リスト ドロップダウン) オプションを複数選択できるようになり、リストから選択されたドロップダウン項目ごとに、行の最後に 1 つのオプションが出力されます。列ごと。

つまり、ドロップダウン リストから Apples、Bananas、および Cherries を選択すると、Apples | バナナ | 最初のセルが空の行の末尾にあるチェリー (| は列区切り記号)。

このためのコードは次のとおりです。

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exitHandler

Dim rngDV As Range
Dim iCol As Integer

If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
   If Target.Column = 3 Then
    If Target.Value = "" Then GoTo exitHandler
    If Target.Validation.Value = True Then
     iCol = Cells(Target.Row, Columns.Count).End(xlToLeft).Column + 1
     Cells(Target.Row, iCol).Value = Target.Value
   Else
     MsgBox "Invalid entry"
     Target.Activate
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True

End Sub

ただし、この VB コードで変更したいのは、選択されたデータ検証で行の最後のセルを埋めることです。列見出しがドロップダウンから選択されたオプションと一致する列の下のセルを埋めたいと思います。

つまり、ドロップダウンで選択されたリンゴは、「リンゴ」というラベルの付いた列の下にあるその行のセルを埋めます。ドロップダウンで選択されたチェリーは、「チェリー」とラベル付けされた列の下のその行のセルを埋めます。理想的には、選択したアイテムの名前を繰り返すのではなく、そのセルに色を付けるか、そこに X を入れます。

上記のコードで何を変更する必要があるかについて誰かがアドバイスできる場合は、大歓迎です。

4

2 に答える 2

1

リクエストどおりにコードを修正しました。列ヘッダーを反復処理して正しい列を見つけ、適切なセルの背景色を変更します。
更新: 無限ループを防ぐためのチェックを追加しました。

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exitHandler

Dim rngDV As Range
Dim iCol As Integer, iColumnHeaderRow As Integer
iColumnHeaderRow = 3 'change this if header row changes

If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Not Intersect(Target, rngDV) Is Nothing Then
    Application.EnableEvents = False
    If Target.Column = 3 Then
        If Target.Value = "" Then GoTo exitHandler
        If Target.Validation.Value = True Then
            'iterate through column headers to find the matching column
            iCol = (Target.Column + 1)
            Do Until Cells(iColumnHeaderRow, iCol).Value = Target.Value
                iCol = iCol + 1
                'if we've hit a blank cell in the header row, exit 
                '(also to prevent an infinite loop here)
                If Cells(iColumnHeaderRow, iCol).Value = "" Then GoTo exitHandler
            Loop

            'set fill color of appropriate cell
            With Cells(Target.Row, iCol).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End With
        Else
            MsgBox "Invalid entry"
            Target.Activate
        End If
    End If
End If

exitHandler:
    Application.EnableEvents = True
End Sub
于 2013-03-26T15:54:30.303 に答える
1

代わりの

Cells(Target.Row, iCol).Value = Target.Value

為に

Cells(Target.Row, Range(Target.Value).Column).Value = "X"

注意: ヘッダー セルに名前を付けた場合にのみ機能します。Range("Banana")たとえば、「Banana」という名前を付けたセルを参照します。

名前を付けるには、画面の左上にあるテキスト ボックスを使用します。そのテキストボックスには、もともと「A1」、「B2」などのセル座標のみが含まれています。名前を付けるヘッダー セルをクリックし、このテキスト ボックスに移動して、「Banana」またはドロップダウン値に一致するその他の名前を入力します。すべてのヘッダーにすべてのドロップダウン値を付けて名前を付けます (欠落しているとエラーが発生します)。

(そして、その iCol 計算を放棄することができます)

于 2013-03-26T13:56:09.557 に答える