Question

我有8个包含各种字母的单元格。我可以做的是一个宏将覆盖内容，如果3个单元格包含'H'。

e.g。

细胞a，b，c，d，e，f，g，h

如果a，b和c包含H，则单元格d，e，f，g和h变为包含X

否则清除细胞内容

下面是我写的这个：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range

' The variable KeyCells contains the cells that will
' cause an alert when they are changed.

Set KeyCells = Range("D5:BD359")

If Not Application.Intersect(KeyCells, Range(KeyCells.Address)) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False

a = 15
b = 45
c = 105
d = 155
e = 210
f = 260
g = 315
h = 345

For x = 0 To 4

For i = 5 To 54

If Cells(a + x, i) = "H" And Cells(b + x, i) = "H" And Cells(c + x, i) = "H" Then
    If Cells(d + x, i) = "" Then
    Cells(d + x, i) = "X"
    End If
    If Cells(e + x, i) = "" Then
    Cells(e + x, i) = "X"
    End If
    If Cells(f + x, i) = "" Then
    Cells(f + x, i) = "X"
    End If
    If Cells(g + x, i) = "" Then
    Cells(g + x, i) = "X"
    End If
    If Cells(h + x, i) = "" Then
    Cells(h + x, i) = "X"
    End If

Else
    If Cells(a + x, i) = "X" Then
    Cells(a + x, i).ClearContents
    End If
    If Cells(b + x, i) = "X" Then
    Cells(b + x, i).ClearContents
    End If
    If Cells(c + x, i) = "X" Then
    Cells(c + x, i).ClearContents
    End If
    If Cells(d + x, i) = "X" Then
    Cells(d + x, i).ClearContents
    End If
    If Cells(e + x, i) = "X" Then
    Cells(e + x, i).ClearContents
    End If
    If Cells(f + x, i) = "X" Then
    Cells(f + x, i).ClearContents
    End If
    If Cells(g + x, i) = "X" Then
    Cells(g + x, i).ClearContents
    End If
    If Cells(h + x, i) = "X" Then
    Cells(h + x, i).ClearContents
    End If

End If
Next i
Next x

Application.EnableEvents = True

End If

End Sub

我可以使用IF函数完成此操作，但编写它需要数天时间。（我有超过7个单元格，但for循环比较所有其他单元格）

有没有人有任何想法如何将其扩展到所有其他55种组合？

Answer 1

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim HCount As Long

' The variable KeyCells contains the cells that will
' cause an alert when they are changed.

Set KeyCells = Range("D5:BD359")

If Not Application.Intersect(KeyCells, Range(KeyCells.Address)) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False

a = 15
b = 45
c = 105
d = 155
e = 210
f = 260
g = 315
h = 345

For x = 0 To 4

For i = 5 To 54

HCount = Application.WorksheetFunction.CountIf(Cells(a + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(b + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(c + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(d + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(e + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(f + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(g + x, i), "H") + Application.WorksheetFunction.CountIf(Cells(h + x, i), "H")

If HCount = 3 Then
    If Cells(a + x, i) = "" Then
    Cells(a + x, i) = "X"
    Cells(a + x, i).Locked = True
    End If
    If Cells(b + x, i) = "" Then
    Cells(b + x, i) = "X"
    Cells(b + x, i).Locked = True
    End If
    If Cells(c + x, i) = "" Then
    Cells(c + x, i) = "X"
    Cells(c + x, i).Locked = True
    End If
    If Cells(d + x, i) = "" Then
    Cells(d + x, i) = "X"
    Cells(d + x, i).Locked = True
    End If
    If Cells(e + x, i) = "" Then
    Cells(e + x, i) = "X"
    Cells(e + x, i).Locked = True
    End If
    If Cells(f + x, i) = "" Then
    Cells(f + x, i) = "X"
    Cells(f + x, i).Locked = True
    End If
    If Cells(g + x, i) = "" Then
    Cells(g + x, i) = "X"
    Cells(g + x, i).Locked = True
    End If
    If Cells(h + x, i) = "" Then
    Cells(h + x, i) = "X"
    Cells(h + x, i).Locked = True
    End If

Else
    If Cells(a + x, i) = "X" Then
    Cells(a + x, i).Locked = False
    Cells(a + x, i).ClearContents
    End If
    If Cells(b + x, i) = "X" Then
    Cells(b + x, i).Locked = False
    Cells(b + x, i).ClearContents
    End If
    If Cells(c + x, i) = "X" Then
    Cells(c + x, i).Locked = False
    Cells(c + x, i).ClearContents
    End If
    If Cells(d + x, i) = "X" Then
    Cells(d + x, i).Locked = False
    Cells(d + x, i).ClearContents
    End If
    If Cells(e + x, i) = "X" Then
    Cells(e + x, i).Locked = False
    Cells(e + x, i).ClearContents
    End If
    If Cells(f + x, i) = "X" Then
    Cells(f + x, i).Locked = False
    Cells(f + x, i).ClearContents
    End If
    If Cells(g + x, i) = "X" Then
    Cells(g + x, i).Locked = False
    Cells(g + x, i).ClearContents
    End If
    If Cells(h + x, i) = "X" Then
    Cells(h + x, i).Locked = False
    Cells(h + x, i).ClearContents
    End If

End If

Next i
Next x

Application.EnableEvents = True

End If

End Sub

这用于确保团队中只有3名成员能够立即预订假期。 X只是链接到条件格式和保护锁定单元格的表单，因此无法选择它们。

使用宏来比较7个细胞中的3个

1 个答案: