Question

我是VBA的初学者，想知道工作表事件中的循环列。以下是情景。

当我选择触发单元格（目标）时，我想填充数据验证和“填充此单元格”注释，而不仅仅是在行中。下面是我试图更新的代码，但真正无望使其工作。

非常感谢你的帮助。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim cel As Range
Dim myRow As Long


Set ws = ThisWorkbook.Sheets("Sheet1")
    'This subroutine fires when a cell value changes in this worksheet.
   Set KeyCells = Range("A5:A8")
    'did someone change something specifically in cell A5?
    If Not Intersect(Target, KeyCells) Is Nothing Then
        For Each cel In Target.Rows ' do the next steps for each cell that was changed
        myRow = cel.Row
        'Is the value A or C?
        If Target.Value = "A" Or Target.Value = "C" Then
            For Each col In Target.Columns '---I added this but not working, 
                myCol = col.Columns.Offset(3)
                ws.Range("C" & myCol).Validation.Delete '---I added this but not working
            'Remove any data validation for this cell:
                ws.Range("C" & myRow).Validation.Delete
            'and change the value of C5 to "Fill in this cell"
                ws.Range("C" & myRow).Value = "Fill in this cell"
                ws.Range("C" & myCol).Value = "Fill in this cell" '---I added this but not working
            Next col '---I added this but not working
        End If
        Application.EnableEvents = True
    Next cel
    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim ws As Worksheet
Dim cel As Range
Dim myRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
    'This subroutine fires when a user selects a different cell or range.
    'So... it fires ALL The time so the next line is super important.
    Set KeyCells2 = Range("C5:C8")
    'Did someone change selection specifically to cell C5?
    If Not Intersect(Target, KeyCells2) Is Nothing Then
        For Each cel In Target ' do the next steps for each cell that was changed
        myRow = cel.Row
        'Is the value currently "Fill in this cell"?
        If ws.Range("C" & myRow).Value = "Fill in this cell" Then
            'Empty the cell
            ws.Range("C" & myRow).Value = ""
            'Add data validation to some list somewhere
            With ws.Range("C" & myRow).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="=$J$1:$J$4"  'This the range that the list exists in
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
        Next cel
    End If
End Sub

Answer 1

这会将更改过的单元格的值复制到Worksheet_change事件中的C5：BV5：

Private Sub Worksheet_Change(ByVal Target As Range)

    Target.Copy
    Range("C5:BV5").PasteSpecial
    Application.CutCopyMode = False

End Sub

Answer 2

将此输入到您的工作表模块。请注意，声明了全局变量

Private previousValue As String
Private previousRange As Range

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyIntersect1 As Range
Dim KeyIntersect2 As Range
Dim eachCell1 As Range
Dim eachCell2 As Range
Dim strHolder As String

Application.EnableEvents = False
Set KeyIntersect1 = Intersect(Target, Range("A5:A8"))   '<~ get intersect
If Not KeyIntersect1 Is Nothing Then                    '<~ check if change happened here
  For Each eachCell1 In KeyIntersect1                   '<~ loop through. in case copy/pasted
    strHolder = eachCell1.Value
    eachCell1.Value = strHolder
    If eachCell1.Value = "A" Or eachCell1.Value = "C" Then  '<~ check the new values
      Set KeyIntersect2 = ActiveSheet.Range(eachCell1.Offset(0, 2), eachCell1.Offset(0, 73))
      For Each eachCell2 In KeyIntersect2               '<~ loop through columns
        eachCell2.Value = "Fill in this cell"           '<~ fill them with values
      Next
    End If
  Next
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim eachCell As Range
Dim KeyIntersect As Range

    If previousRange.Value = "" Then        '<~checks if the previous range is blank
      previousRange.Value = previousValue   '<~if so gives previous value
    End If

    If Target.Value = "Fill in this cell" Then  '<~if the target is default value
      previousValue = "Fill in this cell"       '<~give this to value holder
      Set previousRange = Target                '<~and set it to previous range
                                                '<~if there is no change it will be checked later
      Target.Value = ""                         '<~cleans this cell.ready for input
    End If
Set KeyIntersect = Intersect(Target, Range("C5:C8"))
If Not KeyIntersect Is Nothing Then
  For Each eachCell In KeyIntersect
    With eachCell
      With .Validation
        .Delete
        .Add Type:=xlValidateList, _
                     AlertStyle:=xlValidAlertStop, _
                     Operator:=xlBetween, _
                     Formula1:="=$J$1:$J$4"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
      End With
    End With
  Next
End If
End Sub

如果前一个单元格中存在有效值。它不会给“填写这个单元格”。我希望这会有所帮助。

Answer 3

我也能为此创建一些解决方案。

Private Sub Worksheet_Change（ByVal Target As Range） Dim ws As Worksheet 昏暗的cel作为范围 Dim myRow As Long

设置ws = ThisWorkbook.Sheets（＆＃34; Sheet1＆＃34;）＆＃39;当此工作表中的单元格值发生更改时，将触发此子例程。设置KeyCells =范围（＆＃34; A5：A8＆＃34;）＆＃39;有人在小区A5中有特别改变的东西吗？如果Not Intersect（Target，KeyCells）则没有对于每个cel在Target.Rows＆＃39;为每个已更改的单元格执行后续步骤 myRow = cel.Row 对于columnid = 4到8 ＆＃39;值A还是C？如果Target.Value =＆＃34; A＆＃34;或Target.Value =＆＃34; C＆＃34;然后

             ws.cells(myRow, columnID).Validation.Delete
        'and change the value of C5 to "Fill in this cell"
            ws.cells(myRow, columnID).Value = "Fill in this cell"

下一个columnID 万一 Application.EnableEvents = True 下一个cel 结束如果

End Sub

工作表更改事件中的列循环

3 个答案: