CODEWITHSUNDEEP
excelvbaexcel-formula
Black Mamba
Black Mamba

Reputation: 245

How set Each For keep current cell check until a condition be true VBA

I want to check if a cell in a sheet s4 has the same value for each cell in the sheet s1

So i tried to "stop" the Next c setting the c value as the previous cell, until the condition be true.

i put msgbox c.Value & "hiiiii" to check the c position, and is always the next cell.

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

There's a way to make it works?

Thank you

my s1 sheet

my s4 sheet

EDIT 1:

After some hours of breaking my head i changed the code and now it is working:

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

A special thanks for Cyril and his tip about the another for options.

Upvotes: 0

Views: 183

Answers (1)

JB-007
JB-007

Reputation: 2461

Screenshots/here refer:

CONSTRUCT

  1. Fixed: comprises list of cells - press CMD button 'RUN' to select which values you want to compare against every populated cell of every other sheet.

This runs the macro Soln() (below).

  1. test1-test3: arbitrary sheets comprising a medley of matching and mis-matched cell values/text etc. (contiguous / isolated cells etc.). Most content in test 1.

  2. Audit_Trail: This will be removed/deleted if it exists when you run the macro so that a fresh sheet can be produced. This will display, for each target cell (selected step 1) and sheet (see 2) every cell (sheet/link/content) that did not match the respective target values.

CODE

(essential modules: Soln(), select cells - all the rest is 'bonus' - hope this works/helps you - assuming I understood issue correclty☺.)

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 DEMO

Demo gif

OTHER INFO

  • To replicate for a single value, simply uapte the list in 1 (fixed) accordingly
  • This also creates a pivot in the Audit_Trail sheet summarises the extent of mismatches per sheet for each desired 'target value'.

Upvotes: 1

Related Questions