VBA - If Consecutive Zeros in an Array

[FormalAbility1]

I have written some VBA code that randomly generates a 1 or 0 depending on a probability. It then stores these into an array, which is defined by the the number of data points I have (rows) and by the number of iterations the user wants to run through (columns).I have transposed the data into excel and it looks as I'd expect, e.g.1 0 11 1 11 0 10 0 1 0 0 11 1 01 0 1Unfortunately I am not too familiar with VBA so I am struggling with the next part; I would like to now consider one column (iteration) and find if there are 3 consecutive zeros. If there are, I would like to create a new array that inputs a 1 when there are 3 consecutive zeros found, and a 0 otherwise. So the above example would look like0 1 0This would allow me to do some analysis on the number of 1's to 0's etc.My code so far is shown belowPrivate Sub CommandButton1_Click()Dim Time As DoubleDim arr As VariantDim PD As DoubleDim PD1 As DoubleDim NoOfPoints As IntegerDim y As IntegerDim i, x, k, m, f As Integer'-----------RPM = RPMInputTextboxPD = PDInputTextboxTime = TimeInputTextboxi = iterInputTextboxk = 1m = 1PD1 = PDNoOfPoints = Int(Time * (RPM / 60))ReDim arr(1 To i, 1 To NoOfPoints)For k = 1 To i 'Iteration loop For m = 1 To NoOfPoints 'Track Points Loop x = Rnd() If x > PD1 Then y = 0 Else: y = 1 End If arr(k, m) = y Next mNext kActiveSheet.Range("A1:CV8").Value = WorksheetFunction.Transpose(arr)End Sub

 

[Andrew Fergus]

Hello and welcome to MrExcel

Your posts was really hard to understand given the lack of formatting - in future I recommend you use code tags to show your VBA code to make it easier to read. I think I understand what you want.

The code below has your original code with a few tweaks. I don't have the form with the input Text boxes so instead I forced some of the variables to fixed values - you will be able to see where I did this by commenting out your variable declaration and inserting my own immediately below - I recommend you change it back to what you had for your simulation and comment out my declarations for i, PD1 and NoOfPoints. I also made a couple of other tweaks, especially inside the "If Then Else" section, changed x to being a double (the rnd function returns a value between 0 and 1), added a new array called arrChk and I also changed how the array is written back to the workbook. Notice I also added "option 1" at the top of the code, this forces the arrays to start at 1 instead of 0 (i.e. 1 to 100 instead of 0 to 100).

Below that I have added some new code to check each simulation for triple zeroes - if it finds an instance of a triple zero it writes a 1 to the new array, otherwise a 0. The output from this new array is pasted in row 10 on the same worksheet so you can see it - change this to be output wherever you want it.

I trust this helps.

Option Base 1


Sub CommandButton1_Click()


Dim Time, PD, PD1, x As Double
Dim arr() As Variant, arrChk() As Variant
Dim NoOfPoints, y, i, k, m As Integer
'-----------


'RPM = RPMInputTextbox
'PD = PDInputTextbox
'Time = TimeInputTextbox


'i = iterInputTextbox
i = 100


'PD1 = PD
PD1 = 0.4


'NoOfPoints = Int(Time * (RPM / 60))
NoOfPoints = 8


ReDim arr(1 To i, 1 To NoOfPoints)


For k = 1 To i 'Iteration loop
    For m = 1 To NoOfPoints 'Track Points Loop
        x = Rnd()
        If x > PD1 Then
            arr(k, m) = 0
        Else
            arr(k, m) = 1
        End If
    Next m
Next k


'ActiveSheet.Range("A1:CV8").Value = WorksheetFunction.Transpose(arr)
ThisWorkbook.Sheets(1).Range("A1:CV8").Value = WorksheetFunction.Transpose(arr)


'Check instances of triple zero
ReDim arrChk(i)
For k = 1 To i
    x = 0
    For m = 1 To NoOfPoints
        If arr(k, m) = 0 Then
            x = x + 1
        Else
            x = 0
        End If
        If x = 3 Then
            arrChk(k) = 1
            Exit For
        ElseIf m = NoOfPoints Then
            arrChk(k) = 0
        End If
    Next m
Next k


ThisWorkbook.Sheets(1).Range("A10:CV10").Value = arrChk




MsgBox "Finished!", vbInformation, "Done"


End Sub

 

[Rick Rothstein]

Option Base 1


Sub CommandButton1_Click()

Dim Time, PD, PD1, x As Double
Dim arr() As Variant, arrChk() As Variant
Dim NoOfPoints, y, i, k, m As Integer
'-----------

'RPM = RPMInputTextbox
'PD = PDInputTextbox
'Time = TimeInputTextbox

'i = iterInputTextbox
i = 100

'PD1 = PD
PD1 = 0.4

'NoOfPoints = Int(Time * (RPM / 60))
NoOfPoints = 8

ReDim arr(1 To i, 1 To NoOfPoints)

For k = 1 To i 'Iteration loop
    For m = 1 To NoOfPoints 'Track Points Loop
        x = Rnd()
        If x > PD1 Then
            arr(k, m) = 0
        Else
            arr(k, m) = 1
        End If
    Next m
Next k

'ActiveSheet.Range("A1:CV8").Value = WorksheetFunction.Transpose(arr)
ThisWorkbook.Sheets(1).Range("A1:CV8").Value = WorksheetFunction.Transpose(arr)

'Check instances of triple zero
ReDim arrChk(i)
For k = 1 To i
    x = 0
    For m = 1 To NoOfPoints
        If arr(k, m) = 0 Then
            x = x + 1
        Else
            x = 0
        End If
        If x = 3 Then
            arrChk(k) = 1
            Exit For
        ElseIf m = NoOfPoints Then
            arrChk(k) = 0
        End If
    Next m
Next k

ThisWorkbook.Sheets(1).Range("A10:CV10").Value = arrChk

MsgBox "Finished!", vbInformation, "Done"

End Sub

You can replace what I highlighted in red above (you will need to scroll down the code to see it) with this and your macro will still work the same...

[table="width: 500"]
[tr]
	[td]For k = 1 To i
    arrChk(k) = InStr(Join(Application.Transpose(Cells(1, k).Resize(NoOfPoints)), ""), "000")
Next k[/td]
[/tr]
[/table]

 

[Andrew Fergus]

Thanks Rick. That gives a different answer and is not how I interpreted the second array would be populated. You might want the OP to clarify.

[Edit] I just did a speed test and found that method is half as slow as what I posted. I'm surprised.