Question

我一直在努力找出这个问题。为了简化我的工作，我基本上是想将F列设置为下拉列表（例如：苹果，香蕉，橙子，芒果等），用户可以在下拉列表中用一行选择多个项目。中断，并且在F列中选择的任何下拉项都将“镜像”或复制到G列。因此，例如：

F列：

Apples

Bananas

Oranges

在G列中：

Apples

Bananas

Oranges

现在，在G列中，我需要能够为F中选择的每个项目写笔记。因此，使用上面的示例：

G列：

Apples: Round and Red

Bananas: Long and Yellow

Oranges: Round and Orange

我不希望将在G列中写的任何评论复制到F列中。
我遇到的麻烦是，当我需要在F列中添加另一个项目（例如芒果）时，镜像效果会复制以前在F列中选择的所有下拉项目。例如：

F列：

Apples

Bananas

Oranges

Mango (*newly added*)

G列：

Apples: Round and Red

Bananas: Long and Yellow

Oranges: Round and Orange

Apples

Bananas

Oranges

Mango

每次添加项目时，它都会重新镜像。我基本上需要VBA代码仅添加Mango，而不是将先前的下拉项目重新镜像到G列中。注意：如果我在F列中取出一个项目，则不需要该项目和注释从G列中消失。我只需要F列中的添加项即可出现在G列中，而其他项目不再出现。

到目前为止，我的代码如下：

Private Sub
Worksheet_Change(ByVal Target As  Range)
    Dim oldVal As String, newVal     As String
    Dim i As Long
    Dim bMatch As Boolean
    Dim vItems As Variant


    If Target.Count > 1 Or _
        Target.Column <> 6 Then GoTo exitHandler


    On Error Resume Next
    If Target.SpecialCells(xlCellTypeSameValidation).Cells.Count = 0 _
        Then Exit Sub
    On Error GoTo exitHandler


    Application.EnableEvents = False
    newVal = Target.Value
    Application.Undo
    oldVal = Target.Value
    Target.Value = newVal


    If oldVal = "" Or newVal = "" Then GoTo exitHandler


    vItems = Split(oldVal, vbNewLine)
    For i = 0 To UBound(vItems)
          If vItems(i) = newVal Then
              bMatch = True
              vItems(i) = "~Filter Out~"
          End If
    Next i
    If bMatch Then  'remove item
          vItems = Filter(vItems, "~Filter Out~", Include:=False, _
              Compare:=vbTextCompare)
          Target.Value = Join(vItems, vbNewLine)
    Else   'append item
        Target.Value = oldVal & vbNewLine & newVal
    End If

If Target.Column = 6 Then 'it's a column F value that changed
Dim OnlyAddNew As Boolean
OnlyAddNew = InStr(1, Cells(Target.Row, Target.Column + 1), Cells(Target.Row, Target.Column), vbTextCompare) > 0
If OnlyAddNew = True Then
Selection.clearcontent
End If
If OnlyAddNew = False Then
Cells(Target.Row, Target.Column + 1) = Cells(Target.Row, Target.Column + 1) & vbNewLine & Cells(Target.Row, Target.Column)
End If
End If



exitHandler:
    Application.EnableEvents = True
End Sub

我希望我一切都解释得很好。如果您不了解我的目标/我的行为，请发表评论。衷心感谢您的事先帮助。

Answer 1

尝试这样的尝试：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strBreak As String
Dim strAddVal As String
Dim strOldChosen As String
Dim strNewChosen As String
Dim strOldVal As String
Dim strNewVal As String
Dim blnAddVal As Boolean
Dim arrLines() As String

    If Target.Count = 1 Then
        If Target.Column = 6 Then
            If Target.SpecialCells(xlCellTypeSameValidation).Cells.Count > 0 Then
                If Not IsNull(Target.Value) And Target.Value <> "" Then
                    Application.EnableEvents = False
                    strAddVal = Target.Value
                    strOldVal = Cells(Target.Row, Target.Column + 1).Value
                    Application.Undo
                    strOldChosen = Target.Value

                    ' Process Chosen Values (F)
                    strBreak = ""
                    blnAddVal = True
                    strNewChosen = ""
                    If strOldChosen <> "" Then
                        arrLines = Split(strOldChosen, vbLf, , vbTextCompare)
                        For Each strLine In arrLines
                            If strLine = strAddVal Then
                                blnAddVal = False
                            Else
                                strNewChosen = strNewChosen & strBreak & strLine
                                If strBreak = "" Then strBreak = vbLf
                            End If
                        Next
                    End If
                    If blnAddVal = True Then
                        strNewChosen = strNewChosen & strBreak & strAddVal
                    End If
                    Target.Value = strNewChosen

                    ' Process Mirrored Values (G)
                    strBreak = ""
                    blnAddVal = True
                    If strOldVal <> "" Then
                        strBreak = vbLf
                        arrLines = Split(strOldVal, vbLf, , vbTextCompare)
                        Dim i As Integer
                        i = 1
                        For Each strLine In arrLines
                            If strLine Like (strAddVal & "*") Then
                                blnAddVal = False
                            End If
                        Next
                    End If
                    If blnAddVal = True Then
                        strNewVal = strOldVal & strBreak & strAddVal
                        Cells(Target.Row, Target.Column + 1).Value = strNewVal
                    End If
                    Application.EnableEvents = True
                End If
            End If
        End If
    End If

End Sub

一列到另一列的条件镜像

1 个答案: