更新

Question

我需要将excel表单中的数据与其输入数据的工作表上的一列进行比较，然后，如果存在相同的数据，则将已经存在的数据的另一个单元格更改为0。

我有需要连续记录的数据，不能删除重复项-跟踪日期为“有效”。

我有一个数据输入表单，其中包含Item，Date和1（在那里显示1表示该日期是活动的）。表单在“ ItemData”表的最后一行/下一个空行中输入数据。

$A="Item"    $B="Date"    $C="Active(1)"

    $A |    $B    | $C  
$1  I1 |  1-5-19  | 1 
$2  I2 |  1-8-19  | 1
$3  I3 |  1-9-19  | 1
$4  I1 |  1-9-19  | 1
$5  I4 |  1-9-19  | 1
$6  I2 |  1-10-19 | 1
$7  Next time submit button click data goes here

我需要-在“提交”按钮上单击表单将最后一个条目中的“项目”，“日期和活动”（上例中的$ 7）与工作表上的所有其他条目进行比较。

如果新条目（$ 7）“项目” $ A与$ A中的任何其他条目相同，并且“日期”（$ B）在新条目日期（$ B $ 7）和“有效”之前（ $ C）也= 1，然后将匹配项的$ C“活动”从1更改为0，并留下新条目$ C $ 7 =1。

我知道...令人困惑吧？！？

基本上以上面的示例为例。当我在表单上“提交”时，出现以下新条目：

    $A |    $B     | $C  
$7  I1 |  1-11-19  | 1

它将在$ A中找到所有“ I1”，在$ B中找到“ 1-11-19”之前的日期，在$ C中找到“ 1”。然后，将这些条目中的$ C中的每个“ 1”更改为“ 0”。

示例：

      $A |    $B    | $C  
  $1  I1 |  1-5-19  | 0 
  $2  I2 |  1-8-19  | 1
  $3  I3 |  1-9-19  | 1
  $4  I1 |  1-9-19  | 0
  $5  I4 |  1-9-19  | 1
  $6  I2 |  1-10-19 | 1
  $7  I1 |  1-11-19 | 1

然后当然是表单上的下一个“提交”，用于另一个新条目：

    $A |    $B     | $C  
$8  I2 |  1-12-19  | 1

它应该在$ A中找到所有“ I2”，在$ B中找到“ 1-12-19”之前的日期，在$ C中找到“ 1”。然后，将这些条目中的$ C中的每个“ 1”更改为“ 0”。

示例：

      $A |    $B    | $C  
  $1  I1 |  1-5-19  | 0 
  $2  I2 |  1-8-19  | 0
  $3  I3 |  1-9-19  | 1
  $4  I1 |  1-9-19  | 0
  $5  I4 |  1-9-19  | 1
  $6  I2 |  1-10-19 | 0
  $7  I1 |  1-11-19 | 1
  $8  I2 |  1-12-19 | 1

我尝试并失败了许多不同的代码尝试，这令人尴尬，因此我无法提交“我的代码”，因为我显然不知道从哪里开始。如果有人可以帮助我，我将不胜感激！

================================================ ======================

更新

好，所以我不知道如何使用自动过滤器... 但是现在我已经有了一个很好的基础！我仍然需要一些帮助来修改它。

我需要一个条件，仅更改日期在表单字段“ txtDate”中或工作表上最新条目（最后一行D列）中的日期之前的重复项。

这是当前代码：

Dim i As Long
Dim j As Long
Dim lDuplicates As Long
Dim rngCheck As Range
Dim rngCell As Range
Dim rngDuplicates() As Range

'Range
Set rngCheck = ws.Range("$A:$A")

'# of Duplicates found
lDuplicates = 0

'Checking cells in range
For Each rngCell In rngCheck.Cells
    Debug.Print rngCell.Address

'Check non empty cells only
    If Not IsEmpty(rngCell.Value) Then

     'Resize & clear duplicate array
        ReDim rngDuplicates(0 To 0)
     'Setting counter
        i = 0

      'Search method
        Set rngDuplicates(i) = rngCheck.Find(What:=rngCell.Value, After:=rngCell, LookIn:=xlValues, _
                                                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)

      'Check if duplicates exist
        If rngDuplicates(i).Address <> rngCell.Address Then

          'Count duplicates
            lDuplicates = lDuplicates + 1

          'If duplicates exsist then continue filling array
            Do While rngDuplicates(i).Address <> rngCell.Address
                i = i + 1
                ReDim Preserve rngDuplicates(0 To i)
                Set rngDuplicates(i) = rngCheck.FindNext(rngDuplicates(i - 1))
            Loop

          'Set the value of duplicates to 0 and number format to text
            For j = 0 To UBound(rngDuplicates, 1) - 1
                       rngDuplicates(j).Offset(0, 5).Value = "0"
                       rngDuplicates(j).Offset(0, 5).NumberFormat = "@"
            Next j
        End If
    End If
Next rngCell

Answer 1

可能不是很漂亮，但是可以正常工作...

工作代码：

Dim i As Long
Dim j As Long
Dim k As Long
Dim lConNbr As Long
Dim lConDate As Long
Dim lConYes As Long
Dim StartRow As Long
Dim LastRow As Long
Dim lVal1 As Long
Dim lVal2 As Date
Dim lVal3 As Long
Dim lDup As Long
Dim rngCheck As Range
Dim rngCell As Range
Dim rngDup() As Range

StartRow = 2

'Set Variable Names
lVal1 = Me.cboNbr.Value
lVal2 = Me.txtDate.Value
lVal3 = Me.txtYes.Value

'Set Check Range
Set rngCheck = ws.Range("$A:$A")

'Number of Duplicates Found
lDup = 0

'Checking each cell in range
For Each rngCell In rngCheck.Cells

     'Checking only non empty cells
     If Not IsEmpty(rngCell.Value) Then

          'Resizing and clearing duplicate array
          ReDim rngDup(0 To 0)

          'Setting counter to start
          i = 0

          'Starting search method
           Set rngDup(i) = rngCheck.Find(What:=rngCell.Value, LookIn:=xlValues, _
                           LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)

          'Check if at least one duplicate
          If rngDup(i).Address <> rngCell.Address Then

               'Counting duplicates
               lDup = lDup + 1

                         'If yes, continue filling array
                              Do While rngDup(i).Address <> rngCell.Address
                                   i = i + 1
                                   ReDim Preserve rngDup(0 To i)
                                   Set rngDup(i) = rngCheck.FindNext(rngDup(i - 1))
                              Loop

               For k = StartRow To lrow
                    lConNbr = ws.Range("A" & k).Value
                    lConDate = ws.Range("D" & k).Value
                    lConYes = ws.Range("F" & k).Value

                    'Make changes to duplicate cells
                    If lVal1 = lConNbr And lVal3 = lConYes Then
                         For j = 0 To UBound(rngDup, 1) - 1
                              rngDup(j).Offset(0, 5).NumberFormat = "@"
                              rngDup(j).Offset(0, 5).Value = "0"
                         Next j
                    End If
               Next k
          End If
     End If
Next rngCell

VBA-如何比较同一列中的新条目，然后修改另一个单元格

更新

1 个答案: