vba. how to apply a condition in an array.

[montecarlo2012]

Hello.

In this set of number the main condition is to delete any
Set of numbers that have the same different

In the example by simple inspection you can realize
That the first 4 sets have the same pattern [the same differences]
Only the last set is random.
I was wondering if I have to write for example

IF range(“B2”).value – range(“C2”) = range(“C2”).value – range(“D2”) _

And range(“D2’).value – range (“E2”).value = range(“E2”) – range(“F2”)_

And F2 – G2 then

End if
or do not display.
{display ONLY the set of numbers that do not have the same different)

Of course do not work
How can I write this kind of condition

My array is dynamic,
Size at the moment B2 : G xlend

Thank you for the time you take reading this.
any feedback will be appreciated
if there are not feedback I understand also.

 

[DanteAmor]

If all the differences are equal, do you want to delete the data or do you want to delete the entire row or hide the entire row?

 

[DanteAmor]

is to delete any
Set of numbers that have the same different

Try this:

Sub deleteEquals()
  Dim i As Long, j As Long
  Dim n As Double
  Dim dlte As Boolean
  Application.ScreenUpdating = False
  
  For i = Range("B" & Rows.Count).End(3).Row To 2 Step -1
    dlte = True
    n = Range("C" & i).Value - Range("B" & i).Value
    For j = Columns("B").Column To Columns("G").Column - 1
      If Cells(i, j + 1) - Cells(i, j) <> n Then
        dlte = False
        Exit For
      End If
    Next
    If dlte Then Rows(i).Delete
  Next
End Sub

 

[GWteB]

or do not display.
{display ONLY the set of numbers that do not have the same different)

Sub Montecarlo2012()

    Dim oWs       As Worksheet
    Dim r         As Range
    Dim arrData   As Variant
    Dim arrRows() As Variant
    Dim dVal      As Double
    Dim x As Long, y As Long, i As Long, t As Long

    Set oWs = ActiveSheet
    With oWs
        Set r = .Range("B2", .Cells(.Rows.Count, "G").End(xlUp))
    End With

    arrData = r.Value
    For y = LBound(arrData, 1) To UBound(arrData, 1)
        x = LBound(arrData, 2)
        dVal = arrData(y, x) - arrData(y, x + 1)
        For i = 2 To UBound(arrData, 2) - 1
            If arrData(y, x - 1 + i) - arrData(y, x + i) = dVal Then
                'do nothing
            Else
                ReDim Preserve arrRows(t)
                arrRows(t) = y
                t = t + 1
                Exit For
            End If
        Next i
    Next y
    r.EntireRow.Hidden = True
    For i = LBound(arrRows) To UBound(arrRows)
        r.Rows(arrRows(i)).Hidden = False
    Next i
End Sub

 

[montecarlo2012]

DanteAmor // If all the differences are equal, do you want to delete the data.//

Montecarlo2012// Yes, Sir.

DanteAmor // do you want to delete the entire row?
Montecarlo2012 // Yes.

either way, your code delete the row that have the same differences,
Thank you so much.

Because you understand better, what is the difference between the two questions., I don't get it.
I marked as solution,
also click on like.

 

[montecarlo2012]

GWteB Hello Sir.​

Sorry, exactly when I respond to DanteAmor, exactly in that milisecond your answer go through also, wow, yes Sir, you also are right, excellent code, work perfect like Dante's code.
I was wondering about to avoid patterns, and the easy one is this one because is just the same different
but I have patterns like the differences are, for example

1.2.1.2.1 or 2.1.2.1.2 in the first case like 1 - 2 - 4 - 5 - 7 - 8 etc.
do you think is possible to work something like this?
if you don't answer I will understand perfectly, no worries.

one more time, thank you so much for your code, excellent work.

 

[Marc L]

Hi,​

​

you can use the Abs function, may be done with only a single loop, share at least a worksheet attachment with the source & the expected result …​

 

[montecarlo2012]

Hello Mr. Marc L.
Thank you.
I am talking about the patterns here, because if I started the conversation the other way, I think will be really long work sheet
instead to see the set of numbers produced by this patterns, better see the patterns and avoid them.
Just the patterns I have more than 1000 possible patterns.
So just taking the code from DanteAmor and GWteB as started example idea. they avoid the same different
1-1-1-1-1 or 2-2-2-2-2 and they work just with that, not sheet need it.
so the first block on the easy level of patterns are:

1 2 1 2 1 so for example let say start 5 - 6 -8 - 9 - 11 - 12

1 3 1 3 1 so the same idea here 5 - 6 - 9 - 10 - 13 - 14 etc.

1 4 1 4 1

1 5 1 5 1

1 6 1 6 1

1 7 1 7 1

1 8 1 8 1

1 9 1 9 1

do you think it is necessary worksheet for this.
thank you Marc.

 

[Marc L]

​

Forget my previous post - Abs function - as I misunderstood 'cause your new pattern requirement was not in the original post​

so without any attachment my advice is to compare differences / patterns for odd index with odd index and even with even …​

 

[GWteB]

Just the patterns I have more than 1000 possible patterns.

Then you might be interested in the code below. It consists of a class containing all the comparison logic and a separate main procedure.
To make it work, within the VBE insert a Class Module, its code pane will automatically be opened. Press F4 key to open the properties pane and rename the module's current name (e.g. displayed as Class1) in PatternComp. Paste the code below in the PatternComp module pane. The main procedure goes in a standard module.

You are free to compose any numeric pattern you like, delimited by semicolons. Whenever there is a repeating pattern involved it may be shortened, so a pattern of 1 8 1 8 1 8 1 may be shortened to
"1 ; 8" (formatted as string, spaces are allowed and automatically ignored). This example pattern acts like 1 8 1, or 1 8 1 8, or 1 8 1 8 1 depending on the column width of the range to be examined. In cases the count of pattern members exceeds the column count, and meanwhile the first pattern members equal the determined numerical differences, then the result is to be considered TRUE and the involved worksheet row remains untouched. When the result is considered to be FALSE, the involved worksheet row in its entirety will be deleted.

Main procedure (also usage example) > standard module:

Sub Montecarlo2012_r2()

    Dim oWs As Worksheet
    Dim Rng As Range

    Const PATTERN   As String = "2.5; 1; 2; 3; -13.25"
    
    Set oWs = ActiveSheet
    With oWs
        Set Rng = .Range("B2", .Cells(.Rows.Count, "G").End(xlUp))
    End With

    Dim PComp As PatternComp
    Set PComp = New PatternComp
    
    PComp.Go argData:=Rng, argPattern:=PATTERN
    MsgBox PComp.Result
End Sub

PatternComp Class > class module:

Option Explicit

' ============ Class module: PatternComp ==========

Private Const DECIMAL_DELIMITER   As String = "."   ' <<< change to suit according regional settings

Private Type Locals
    CurrArea        As Range
    arrData         As Variant
    arrPattern()    As Variant
    arrRows()       As Variant
    PatternIndex    As Long
    Result          As Boolean
End Type
Private this As Locals

Public Property Get Result() As Boolean
    Result = this.Result
End Property


Public Sub Go(ByVal argData As Range, ByVal argPattern As String)
    
    Dim i As Long, t As Long, Ptrn As Variant
    If Not argData Is Nothing Then
        With this
            If Len(argPattern) > 0 Then
                Set .CurrArea = argData
                .arrData = argData.Value
                Ptrn = Split(argPattern, ";")
                For i = LBound(Ptrn) To UBound(Ptrn)
                    Ptrn(i) = Trim$(Ptrn(i))
                    If Ptrn(i) <> vbNullString Then
                        If Not CheckNumeric(CStr(Ptrn(i)), True) Then
                            ' something wrong with one of the dependencies
                            VBA.Err.Raise vbObjectError + 13, "Class PatternComp", "PatternComp > Go: Pattern consists of non-numeric characters."
                        End If
                        ReDim Preserve .arrPattern(t)
                        .arrPattern(t) = CDbl(Ptrn(i))
                        t = t + 1
                    Else
                    End If
                Next i
                If t > 0 Then
                    CheckRows
                    ShowResults
                    .Result = True
                Else
                    ' empty pattern, nothing to do
                    .Result = False
                End If
            Else
                ' empty pattern, nothing to do
                .Result = False
            End If
        End With
    Else
        ' something wrong with one of the dependencies
        VBA.Err.Raise vbObjectError + 9, "Class PatternComp", "PatternComp > Go: A valid Range object must be passed to this method."
    End If
End Sub


Private Sub ResetPatternIndex()
    this.PatternIndex = LBound(this.arrPattern)
End Sub


Private Function NextPatternItem() As Double
    With this
        NextPatternItem = .arrPattern(.PatternIndex)
        .PatternIndex = .PatternIndex + 1
        If .PatternIndex > UBound(.arrPattern) Then
            .PatternIndex = LBound(.arrPattern)
        End If
    End With
End Function


Private Sub CheckRows()
    
    Dim x As Long, y As Long, i As Long, t As Long
    Dim dVal As Double
    With this
        x = LBound(.arrData, 2)
        For y = LBound(.arrData, 1) To UBound(.arrData, 1)
            ResetPatternIndex
            For i = LBound(.arrData, 2) To UBound(.arrData, 2) - 1
                dVal = NextPatternItem
                If .arrData(y, x + i) - .arrData(y, x + i - 1) = dVal Then
                    'do nothing
                Else
                    ReDim Preserve .arrRows(t)
                    .arrRows(t) = y
                    t = t + 1
                    Exit For
                End If
            Next i
        Next y
    End With
End Sub


Private Sub ShowResults()
    
    Dim i As Long
    With this
        For i = UBound(.arrRows) To LBound(.arrRows) Step -1
            .CurrArea.Rows(.arrRows(i)).EntireRow.Delete
        Next i
    End With
End Sub


Private Function CheckNumeric(ByRef argString As String, Optional ByVal AllowDecimal As Boolean = True) As Boolean
    
    Dim i As Long, sTmp As String
    sTmp = Trim$(argString)
    CheckNumeric = False
    If Len(sTmp) > 0 Then
        For i = 1 To Len(sTmp)
            ' check on each individual character
            Select Case Mid$(sTmp, i, 1)
            Case "0" To "9"
                ' is numeric, so do nothing
            Case "-", "+"
                ' allow minus/plus only at first position of sequence
                If i > 1 Then
                    GoTo SUB_EXIT
                End If
            Case DECIMAL_DELIMITER
                If Not AllowDecimal Then
                    GoTo SUB_EXIT
                End If
                ' allow just ONE delimiter
                If InStr(sTmp, DECIMAL_DELIMITER) < i Then
                    GoTo SUB_EXIT
                End If
            Case Else
                ' don't accept any other character
                GoTo SUB_EXIT
            End Select
        Next i
        CheckNumeric = True
    End If
    
SUB_EXIT:
End Function