低效代码无法找到匹配数据值

  • Z时代
  • 2024-01-10
  • 分类：问答

我与下面的代码段3点的问题：低效代码无法找到匹配数据值

的代码意向：我有数据表，4列（F，G，H和I）宽且X行长（X通常在5和400之间）。我在M列中有一个日期列表，通常不会超过8个日期。表格H列也包含日期。我希望找到两列（H和M）中的日期，并且每当它们出现时，转到列I中的同一行并将其值设置为零，并将其后的值设置为零（因此，如果匹配在H100中，那么I100和I101将被归零）。

问题代码：编辑1）根据反馈。

1）我有，使用if公式（= if（H100 = M12,1,0），验证有一个匹配，就像电子表格看到它一样。如果公式I100和I101具有非零值，当它们应该归零时

2）代码运行，但需要大约3分钟才能通过3张180行数据。可以做些什么来使它更快更高效地运行？它可以有多达30张数据和400行（极端的例子，但可能，在这种情况下，我很乐意让它运行一点）。 3）假设我的数据表在宏运行之前是100行，从第12行开始，在宏之后，列I对于111行具有非零值，对于下一个389为零。有没有办法我可以阻止它填充零，并保持空白？

我后来在列I上使用了一个相关函数，并且0与0之间的巨大一致正在显着地扭曲了这一点。由于提前，

Sub DeleteCells() 
Dim ws As Worksheet 
Dim cell As Range, search_cell As Range 
Dim i As Long 
Dim h As Long 
Application.ScreenUpdating = False 
For Each ws In ThisWorkbook.Worksheets 
    If Not ws.Name = "Cover" Then 
     For Each cell In ws.Range("H12:H500") 
      On Error Resume Next 
      h = ws.Range("G" & Rows.Count).End(xlUp).Row 
      i = ws.Range("L" & Rows.Count).End(xlUp).Row 
      Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole) 
      On Error GoTo 0 
      If Not search_cell Is Nothing Then 
       ws.Range("I" & cell.Row).Value = 0 
       ws.Range("I" & cell.Row + 1).Value = 0 
       Set search_cell = Nothing 
      End If 
     Next cell 
    End If 
Next ws 
Application.ScreenUpdating = True 
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing 
End Sub

回答：

EDIT：测试的代码，将用于0工作，1行数据的在H/M柱，从行12开始？

编辑：更新了单元格以处理有1行数据的情况，未经测试：

我会先给出我的解决方案，这应该是更快，因为它读取的单元到内存第一

请评论，如果它不工作，或者你有进一步的问题

Sub DeleteCells() 
Dim ws As Worksheet 
Dim i As Long 
Dim h As Long 
Dim MColumn As Variant ' for convinence 
Dim HColumn As Variant 
Dim IColumn As Variant 
Application.ScreenUpdating = False 
For Each ws In ThisWorkbook.Worksheets 
    If Not ws.Name = "Cover" Then 'matching the target sheet 
    ' matching the rows where column M's date matches column H's date 
     'starting row num is 12 
     With ws ' for simplifying the code 
      h = .Range("H" & .Rows.count).End(xlUp).Row 
      If h = 12 Then ' CASE for 1 row only 
       If Range("H12").Value = Range("M12").Value Then 
        Range("I12:I13").Value = "" 
       End If 
      ElseIf h < 12 Then 
       ' do nothing 
      Else 
       ReDim HColumn(1 To h - 11, 1 To 1) 
       ReDim MColumn(1 To h - 11, 1 To 1) 
       ReDim IColumn(1 To h - 10, 1 To 1) 
       ' copying the data from worksheet into 2D arrays 
       HColumn = .Range("H12:H" & h).Value 
       MColumn = .Range("M12:M" & h).Value 
       IColumn = .Range("I12:I" & h + 1).Value 
       For i = LBound(HColumn, 1) To UBound(HColumn, 1) 
        If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then 
         If HColumn(i, 1) = MColumn(i, 1) Then 
          IColumn(i, 1) = "" 
          IColumn(i + 1, 1) = "" 
         End If 
        End If 
       Next i 
       'assigning back to worksheet cells 
       .Range("H12:H" & h).Value = HColumn 
       .Range("M12:M" & h).Value = MColumn 
       .Range("I12:I" & h + 1).Value = IColumn 
      End If 
     End With 
    End If 
Next ws 
Application.ScreenUpdating = True 
End Sub

以上是 低效代码无法找到匹配数据值 的全部内容， 来源链接： utcz.com/qa/265752.html

回到顶部