在Excel中使用VBA插入符合3个条件的新条目时，如何删除表中的旧条目？

所以这对我来说有点棘手，因为我三天前开始学习这个

我有一个表，有4列：站点名称|日期|节目名称|状态

当我插入一条新记录时，它将与旧记录匹配——但日期总是不同的

我需要一个代码来添加到我的代码中，允许通过以下方式自动搜索类似记录：Station Name+Program Name-但仅限于当前月份的记录，并在写入新记录之前删除旧的现有记录

---

这是连接到按钮的当前代码：

Sub OK()

Application.ScreenUpdating = False

' Check if all data was filled

With Empt

  If IsEmpty(Sheet1.Range("D4").Value) = True Then
  MsgBox "Please fill all fields"

 ' ElseIf IsEmpty(Sheet1.Range("E4").Value) = True Then
 'MsgBox "Please fill all fields"

  ElseIf IsEmpty(Sheet1.Range("F4").Value) = True Then
   MsgBox "Please fill all fields"

  ElseIf IsEmpty(Sheet1.Range("G4").Value) = True Then
  MsgBox "Please fill all fields"

Else

'Insert data to table

Sheet1.Range("E4").Value = Now()
Sheet1.Range("D4:G4").Copy
Sheet1.Range("A10").Rows("1:1").Insert Shift:=xlDown
MsgBox "All data have been copied!"
Sheet1.Range("D4:G4").ClearContents
'Sheet1.Range("E4").Value = "Auto Fill"

End If
End With

 'CHANGE COLOR OF CELLS

With colrng

NonEmp = Sheet1.Application.CountA(Range("D10:D100000"))

Set MyPlage = Range("D10:D10" & NonEmp)

For Each Cell In MyPlage

Select Case Cell.Value

Case Is = "Completed"
Cell.Interior.ColorIndex = 43

Case Is = "Waiting"
Cell.Interior.ColorIndex = 3

Case Is = "Uploading"
Cell.Interior.ColorIndex = 6

Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone

End Select
Next
End With

' Save records

   Sheet1.Range("A10:E50000").Validation.Delete
   ThisWorkbook.Save
End Sub

---

有人能帮忙吗

---

• 它适用于以下测试文件：

注意：最后一个子项（showStatus）可以替换为3个条件格式规则：

---

• 它适用于以下测试文件：

注意：最后一个子项（showStatus）可以替换为3个条件格式规则：

---

---

请回答几个问题？当您说插入新行时，您是说这是由上面的代码完成的还是基于手动粘贴的事件？在删除匹配项后，您希望它替换行还是在底部创建一个新的行？不查看数据但查看代码有点困难。似乎发生的情况是：1）用户在D4:G4中输入新值。2） 当宏运行时，它会检查是否输入了所有字段。3） 如果是，它总是将数据移动到第10行，我想这就是底部？？4） 然后对结果进行颜色格式化。您是否询问如何删除上个月第4-9行中的匹配行？您好。谢谢。。。第十行是表格的第一行，当现有条目向下移动时，每个新条目都会向下移动（我真的不知道代码中有什么可以这样做，但我喜欢这样做）我不知道如何在这里添加屏幕截图。。。对不起，有几个问题吗？当您说插入新行时，您是说这是由上面的代码完成的还是基于手动粘贴的事件？在删除匹配项后，您希望它替换行还是在底部创建一个新的行？不查看数据但查看代码有点困难。似乎发生的情况是：1）用户在D4:G4中输入新值。2） 当宏运行时，它会检查是否输入了所有字段。3） 如果是，它总是将数据移动到第10行，我想这就是底部？？4） 然后对结果进行颜色格式化。您是否询问如何删除上个月第4-9行中的匹配行？您好。谢谢。。。第十行是表格的第一行，当现有条目向下移动时，每个新条目都会向下移动（我真的不知道代码中有什么可以这样做，但我喜欢这样做）我不知道如何在这里添加屏幕截图。。。对不起，谢谢，我现在就试试看，看看我能不能理解如何让它工作：）好的。。。所以它有问题。。。。。一直停留在这一行：。自动筛选字段：=2，运算符：=xlFilterValues，准则2:=Array（1，Date），如果我取消它，它就会停留在以下位置：Set v=rng.Offset（1，0）。Resize（.Rows.Count-1，.Columns.Count）-然后是-v.SpecialCells（xlCellTypeVisible）.Rows.EntireRow.Delete是否知道原因？我可以替换现有条目或创建新条目。。。不是两者都有，并且无法连接到本月。。。。我为所有的麻烦感到抱歉：）这个问题与B列被格式化为日期（而不是文本或常规）有关-Excel只能在将日期“视”为日期时过滤日期。是否可以检查B列中所有日期值的格式类型：右键单击其中一个日期并在第一个选项卡（数字）中选择“格式单元格”选择的格式是什么？将所有值格式化为日期后，请检查区域设置中的日期：控制面板->区域和语言->高级->其他设置->日期，但如果您记录该列的自动筛选并回发格式（类似于“8/31/2014”），则会更容易我更改了它，但它没有修复错误。但是，我需要它显示时间和日期-因为一些数据是按小时更新的。它需要限制在当前月份-即，如果有类似的数据（pn+sn）从上个月开始，它不应该改变它。谢谢，我现在就试试，看看我是否能理解如何让它工作：）好的……所以它有问题……一直卡在这行：。自动筛选字段：=2，运算符：=xlFilterValues，准则2:=Array（1，Date），如果我取消它，它就会卡在下面：Set v=rng.Offset（1，0）。调整大小（.Rows.Count-1、.Columns.Count）-然后这个-v.SpecialCells（xlCellTypeVisible）.Rows.EntireRow.Delete知道为什么吗？要么我可以替换现有条目，要么创建一个新条目…不是两者都可以，并且无法连接到本月…我为所有的麻烦感到抱歉：）这个问题与B列被格式化为日期有关（不是文本或常规）-Excel只能在将日期“视”为日期的情况下对日期进行筛选。是否可以检查B列中所有日期值的格式类型：右键单击其中一个日期并在第一个选项卡（数字）中选择“格式单元格”选择的格式是什么？将所有值格式化为日期后，请检查区域设置中的日期：控制面板->区域和语言->高级->其他设置->日期，但如果您记录该列的自动筛选并回发格式（类似于“8/31/2014”），则会更容易我更改了它，但它没有修复错误。但是，我需要它显示时间和日期-因为一些数据是按小时更新的。并且它需要限制在当前月份-即，如果有上个月的类似数据（pn+sn），那么它不应该更改它。

Option Explicit

Public Sub OK()
    Dim ws As Worksheet, ur As Range, lr As Long, inc As Range, ref As Range

    Set ws = Worksheets("Main")
    Set inc = ws.Range("D4:G4") 'Insert Data
    Set ref = ws.Range("A9")    'Station
    With ws
        lr = .Cells(.Rows.Count, 4).End(xlUp).Row

        If inputIsValid(.Range("D4,F4,G4")) Then
            Application.ScreenUpdating = False
            Set ur = .Range(ref, "D" & lr)
            removePrev ur, .Range("D4"), .Range("F4")
            .Range("E4").Value = Now

            inc.Copy
            ref.Rows(2).Insert Shift:=xlDown
            inc.ClearContents
            With ref.Offset(1, 3)
                Select Case .Value2
                    Case "Completed":   .Interior.ColorIndex = 43
                    Case "Waiting":     .Interior.ColorIndex = 3
                    Case "Uploading":   .Interior.ColorIndex = 6
                End Select
            End With
            .Range("D4").Activate
            ThisWorkbook.Save
            Application.ScreenUpdating = True
        End If
    End With
End Sub

Private Function inputIsValid(ByRef inRng As Range) As Boolean
    Dim cel As Range, result As Boolean, invRng As Range
    result = True
    For Each cel In inRng
        If Len(cel) = 0 Then
            If invRng Is Nothing Then Set invRng = cel Else Set invRng = Union(invRng, cel)
            result = False
        End If
    Next
    If Not result Then
        invRng.Interior.Color = vbBlue
        MsgBox "Please enter values in blue cell(s)"
        invRng.Interior.ColorIndex = xlColorIndexAutomatic
        ThisWorkbook.Saved = True
    End If
    inputIsValid = result
End Function

Private Sub removePrev(ByRef rng As Range, ByVal sn As String, pn As String)
    Dim v As Range
    With rng
        Set v = rng.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
        On Error Resume Next
        .AutoFilter Field:=1, Criteria1:=sn
        If v.SpecialCells(xlCellTypeVisible).Count > 1 Then
            .AutoFilter Field:=2, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
            If v.SpecialCells(xlCellTypeVisible).Count > 1 Then
                .AutoFilter Field:=3, Criteria1:=pn
                If .SpecialCells(xlCellTypeVisible).Count > 1 Then
                    v.SpecialCells(xlCellTypeVisible).Rows.EntireRow.Delete
                End If
            End If
        End If
        .AutoFilter
    End With
End Sub