如何设置每个 For 保持当前单元格检查直到条件为真 VBA

Question

我想检查工作表s4 中的单元格是否与工作表s1 中的每个单元格具有相同的值

所以我试图“停止”Next c 将c 值设置为前一个单元格，直到条件为真。

我输入msgbox c.Value & "hiiiii" 来检查c 的位置，并且始终是下一个单元格。

Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet
Dim s4 As Worksheet

Set s1 = ThisWorkbook.Sheets("test1")
Set s2 = ThisWorkbook.Sheets("test2")
Set s3 = ThisWorkbook.Sheets("test3")
Set s4 = ThisWorkbook.Sheets("test4")


Dim l As Integer


l = 8

lastrow = s4.Range("J" & s4.Rows.count).End(xlUp).row

Set rd = s4.Range("J2:J" & lastrow)
Set rf = s1.Range("A" & l)


For Each c In rd
    msgbox c.Value & "hiiiii"
    If rf.Value = "" Then: Exit For
    If c.Value = rf.Value Then
        s1.Range("B" & l).Value = c.Offset(, -1)
        l = 8
        Set rf = s1.Range("A" & l)
    Else
    
        l = l + 1
        Set rf = s1.Range("A" & l)
        Set c = c.Offset(-1, 0)
    End If
Next c

有办法让它工作吗？

谢谢

编辑1：

经过几个小时的努力，我改变了代码，现在它可以工作了：

Dim l As Integer
Dim i As Integer

lastrow = s4.Range("J" & s4.Rows.count).End(xlUp).row
LastRow2 = s1.Range("A" & s1.Rows.count).End(xlUp).row

l = 8
i = 8

Set rd = s4.Range("J2:J" & lastrow)
Set rf = s1.Range("A" & i)

For Each c In rd
       
If c.Value <> rf.Value Then
    
For i = 8 To LastRow2
    Set rf = s1.Range("A" & i)
If rf.Value = c.Value Then
    rf.Offset(, 1).Value = c.Offset(, -1)
End If
Next i

Else
    rf.Offset(, 1).Value = c.Offset(, -1)
    End If
Next c

End Sub

特别感谢Cyril 和他关于另一个for 选项的提示。

Answer 1

截图/here参考：

---

构造

1. 已修复：包含单元格列表 - 按 CMD 按钮“运行”以选择要与每个其他工作表的每个填充单元格进行比较的值。

   这将运行宏 Soln()（如下）。

   2. test1-test3：任意表，包括匹配和不匹配的单元格值/文本等（连续/隔离单元格等）。测试 1 中的大部分内容。

   3. Audit_Trail：如果在您运行宏时存在，它将被删除/删除，以便生成新的工作表。对于每个目标单元格（选择的步骤 1）和工作表（参见 2），这将显示与各自目标值不匹配的每个单元格（工作表/链接/内容）。

   ---

   代码

   （基本模块：Soln()，选择单元格 - 其余的都是'奖金' - 希望这能工作/帮助你 - 假设我理解问题正确☺。）

   Global addr(), target_cells(), s As String
   
   
   
   Sub s_(new_txt)
       Application.StatusBar = False
       s = s & " --> " & new_txt
       Application.StatusBar = s
   End Sub
   
   
   Sub Soln()
       Application.StatusBar = False
       s_ ("sub soln")
       'Application.StatusBar = "Sub Soln()"
       ReDim Preserve addr(0), target_cells(0)
       Sheets("fixed").Move Before:=Sheets(1)
       Call select_cells
       Application.ScreenUpdating = False
       m = -1
       N_ = -1
       K_ = -1
       
       'Sheets(1).Activate
       If sheet_exists("Audit_Trail") Then
           Application.DisplayAlerts = False
           Sheets("Audit_Trail").Delete
           ThisWorkbook.Sheets.Add( _
                       After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "Audit_Trail"
           Application.DisplayAlerts = True
       End If
       
       With Sheets("Audit_Trail")
       
           .Range("a1").Value = "Target_value"
           .Range("b1").Value = "Sheet"
           .Range("c1").Value = "Link/Content"
   
       End With
       
       For Each sh In ActiveWorkbook.Sheets
           For Each yy In target_cells
   
               sh.Activate
               If (sh.Name = "fixed") Or (sh.Name = "Audit_Trail") Then
                   Exit For
                   'ActiveSheet.Next.Select
               Else
                   On Error Resume Next
   
                   Selection.SpecialCells(xlCellTypeConstants, 23).Select
                   For Each c In Selection
   
   
                       If c.Value = yy Then
                           Resume Next
                       Else
                           addr_temp = Evaluate("ADDRESS(" & c.Row & "," & c.Column & ",1,1,""" & c.Worksheet.Name & """)")
                           With Sheets("Audit_Trail")
                               m = m + 1
                               .Range("a2").Offset(m).Value = yy
                               .Range("b2").Offset(m).Value = sh.Name
                               .Range("c2").Offset(m).Value = "=" & addr_temp
                           End With
                       End If
                   Next
               End If
           Next
       Next
       Application.ScreenUpdating = True
       Application.StatusBar = False
       Call pivot_summary
       
   End Sub
   
   
   Sub select_cells()  '@Tim Williams (2011) - https://stackoverflow.com/questions/7353711/let-the-user-click-on-the-cells-as-their-input-for-an-excel-inputbox-using-vba
       s_ ("sub select_cells()")
       Dim rRange As Range
       
       N_ = -1
       On Error Resume Next
   
       Application.DisplayAlerts = False
       Sheets("fixed").Activate
       Default_ = Sheets("fixed").Range("J2:J4").Address
       Set rRange = Application.InputBox(Prompt:= _
           "Please select range with cells you would like to compare against every other cell in this workbook.", Title:="SPECIFY RANGE", Default:=Default_, Type:=8)
   
       
   
           Application.DisplayAlerts = True
   
           If rRange Is Nothing Then
              Exit Sub
           Else
             For Each c In rRange
                   N_ = N_ + 1
                   ReDim Preserve target_cells(0 To N_)
                   target_cells(N_) = c.Value
             Next
   
           End If
   
       Return
   
   
   
   End Sub
   
   
   
   Function sheet_exists(sh As String) As Boolean
       s_ ("sheet_exists()")
       'Dim w As Excel.Worksheet
       On Error GoTo eHandle
       Set w = ThisWorkbook.Worksheets(sh)
       sheet_exists = True
   
       Exit Function
   eHandle:
       sheet_exists = False
   End Function
   
   
   
   '******not really required - could ignore *********'
   
   Sub pivot_summary()
   
       Range("a1").Select
       Range(Selection, Selection.End(xlDown)).Select
       Range(Selection, Selection.End(xlToRight)).Select
       
       
       
       ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
           Selection, Version:=8).CreatePivotTable TableDestination:= _
           ActiveSheet.Range("g2"), TableName:="PivotTable5", _
           DefaultVersion:=8
       With ActiveSheet.PivotTables("PivotTable5").PivotFields("Target_value")
           .Orientation = xlRowField
           .Position = 1
       End With
       With ActiveSheet.PivotTables("PivotTable5").PivotFields("Sheet")
           .Orientation = xlRowField
           .Position = 2
       End With
       ActiveSheet.PivotTables("PivotTable5").AddDataField ActiveSheet.PivotTables( _
           "PivotTable5").PivotFields("Link/Content"), "Sum of Link/Content", xlSum
       With ActiveSheet.PivotTables("PivotTable5").PivotFields("Sum of Link/Content")
           .Caption = "Count of Link/Content"
           .Function = xlCount
       End With
       ActiveSheet.PivotTables("PivotTable5").CompactLayoutRowHeader = "Target"
       Range("H2").Select
       ActiveSheet.PivotTables("PivotTable5").DataPivotField.PivotItems( _
           "Count of Link/Content").Caption = "# mismatch"
       Columns("G:H").Select
       Selection.ColumnWidth = 11.27
       Selection.Font.Name = "Brush Script MT"
       Range("G22").Select
       ActiveCell.FormulaR1C1 = "That's all folks! ?"
       Range("G23").Select
       ActiveWorkbook.Save
   End Sub
   

   ---

   GIF 演示

   ---

   其他信息

   • 要复制单个值，只需相应地在 1 中复制列表（固定）
   • 这还会在 Audit_Trail 工作表中创建一个数据透视表，汇总每个工作表中每个所需“目标值”的不匹配程度。

   ---