vba array element removal - vba

j = LBound(arrayTime)
Do Until j = UBound(arrayTime)
j = j + 1
b = b + 1
cnc = b + r
MsgBox cnc
If cnc > 7 Then
b = 0
r = 0
cnc = b + r
End If
numMins = Sheet5.Cells(cnc + 3, 2) - arrayTime(j)
If numMins < 0 Then
g = g + 1
ReArrangeArray arrayTime, j
'ReDim Preserve arrayTime(numrows - 1 + g)
'arrayTime(numrows - 1 + g) = arrayTime(j)
'MsgBox (arrayTime(numrows - 1 + g))
Else
Sheet5.Cells(cnc + 3, 2) = numMins
End If
Loop
If the if statement is true I want to be able to put the array value at the end of the array and remove that value from its current spot. As the code is, it just adds it to the end and increases the size of the array from 12 to 13. How can I get the array to remain size 12 and still place the value at the end of the array and then remove it from its original position? I do not want to touch the array values in front. Just want to take that value and move it to the end.
For instance
array(1,2,3,4,5)
If statement
j on third loop.
array(j)=3
end array should be
array(1,2,4,5,3)

You could use a helper Sub like this one:
Sub ReArrangeArray(inputArray as Variant, indexToSwap as long)
Dim I As Long
Dim tempVal As Variant
If indexToSwap >= LBound(inputArray) And indexToSwap < UBound(inputArray) Then
tempVal = inputArray(indexToSwap)
For I = indexToSwap To UBound(inputArray) - 1
inputArray(i) = inputArray(i + 1)
Next I
InputArray(UBound(inputArray)) = tempVal
End If
End Sub
To be called by your main Sub as follows:
ReArrangeArray arrayTime, j

Related

Excel VBA how to set number sequence to start at middle of the row?

I previously have a Excel sheet with VBA coding that fills column, row 1 to 10 with the number 1, row 11 to 20 with number 2 and so on. The code I've used is as follows:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 1, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
Now I want to change it so that the code starts at row 3 onwards. Meaning row 3 to 12 = 1, row 13 to 22 = 2 and so on. So I changed the 'For' statement to:
For c = 3 To 34
But what happens is that the number 1 appears from row 3 to row 10, and then continues with number 2 in row 11 to 20. Not what I was expecting.
Therefore, what would be the best method of changing the code?
If you want exactly the same output but two rows lower, you can use:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 3, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
If you still only want to go to row 34 but start in row 3, change the 34 to 32 in the above code.
You can also do it without looping and this is easier to adjust the parameters:
Sub fill()
Const NUMBER_OF_ROWS As Long = 34
Const START_ROW As Long = 3
Const ID As Long = 1
Const NUMBER_IN_GROUP As Long = 10
With ActiveWorkbook.Sheets("Sheet1").Cells(START_ROW, 1).Resize(NUMBER_OF_ROWS)
.Value = .Parent.Evaluate("INDEX(INT((ROW(" & .Address & ")-" & START_ROW & ")/" & _
NUMBER_IN_GROUP & ")+" & ID & ",)")
End With
End Sub
When i understand you write, this should work:
You can use the loop how you did at the beginning. and just add plus 2 to c in the ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 3, 1) = ID
c= c+1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
something like that should be the simplest way:
Sub fill()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 10
ActiveWorkbook.Sheets("Sheet1").Cells(j + (i - 1) * 10 + 2, 1) = i
Next j
Next i
End Sub
EDIT:
No, the simplest way would be type formula into A3:
=ROUNDDOWN(((ROW()-3))/10,0)+1
end drag it donw.

Where is my error in this visual basic Bubblesort

I am currently making a highscore table - reading the times from a .csv file and sorting them from lowest to highest. The list only becomes partially sorted after the code runs.
All the data inputs correctly but when it goes to sort it sorts the data out incorrectly.
Private Sub BeginnerProcess(ByRef player() As pe_player, ByVal x As Integer)
Dim i As Integer
Dim j As Integer
Dim temp As Object
For i = x To 0 Step -1
For j = 0 To i - 1
If player(j).playerTime > player(j + 1).playerTime Then
temp = player(j)
player(j) = player(j + 1)
player(j + 1) = temp
End If
Next
Next
Dim k As Integer
For k = 1 To x
player(k).position = k
Next
End Sub
Here's the output
Leaderboard
Adapting the classic bubble-sort to your case, I think i should be something like the code below:
For i = 0 To x - 1
For j = i + 1 To x
If player(i).playerTime > player(j).playerTime Then
temp = player(i)
player(i) = player(j)
player(j) = temp
End If
Next
Next

Connect Four Horizontal winner

I'm creating a connect four game and I'm having some trouble with the horizontal loop. The loop below works and it's for a vertical win. I have a two labels for each row and two labels for each column one for the color blue and one for the color red. When I add in my other labels I cant seem to find where I take the step-1 in order to change labels and go upwards with the next label. I have also tried adding a whole new loop below that just dedicated to the horizontal winnings.
For i = 5 To 0 Step -1`
If board(i, 0) = 0 Then
board(i, 0) = pturn
If pturn = 1 Then
Labelboard(i, 0).BackColor = Color.Red
CounterB = 0
lblcounterBlue.Text = "Matches = " & CounterB
CounterR = CounterR + 1
lblCounterRed.Text = "Matches = " & CounterR
ElseIf pturn = 2 Then
Labelboard(i, 0).BackColor = Color.Blue
CounterR = 0
lblCounterRed.Text = "Matches = " & CounterR
CounterB = CounterB + 1
lblcounterBlue.Text = "Matches = " & CounterB
End If
pturn = pturn + 1
If pturn = 3 Then pturn = 1
If CounterR = 4 Then
MsgBox("Game Over")
End If
If CounterB = 4 Then
MsgBox("Game Over")
End If
Exit Sub
End If
Next
I don't quite understand your setup, but hopefully this will get you close enough for you to get things working. I'm having to make a few assumptions, but I've tried to declare a constant each time I have to make the code more readable and easier for you to adapt to what you've already written.
What I've written is a function that lets you know if a specific space is part of winning streak. It assumes board() is public. If pturn is also public, you could make this even more efficient as long as you call it every turn, as noted in the comments. If you know which space was the last one played, you can maximize efficiency by only calling the function for that space (assuming you call it at the end of every player turn). If you don't know which space was played last, you can loop through every space in board() and test each one.
Function winner(rowNum As Integer, colNum As Integer) As Integer
'Returns 0 if space does not create a win, or the winning player number if it does
'Change to winner(...) As Boolean <--To only test current player
Dim minRow As Integer = LBound(board, 0)
Dim maxRow As Integer = UBound(board, 0)
Dim minColumn As Integer = LBound(board, 1)
Dim maxColumn As Integer = UBound(board, 1)
'These are the values I assume are in board()
'(I don't actually use them in the code)
Const emptySpace As Integer = 0
Const red As Integer = 1
Const blue As Integer = 2
Dim player As Integer
Dim streak As Integer
Dim r As Integer, c As Integer 'loop placeholders
Dim v As Integer, h As Integer 'control search direction
For v = 0 To 1
For h = -1 To 1
If v = 1 Or h = 1 Then
'These loops and test check each direction (vertical, horizontal and
'both diagonals) for a win exactly once.
player = board(rowNum, colNum)
If player > 0 Then 'If player = pturn <-- to only check current player
streak = 1
'check positive direction
r = rowNum + h
c = colNum + v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r + h
c = c + v
End If
Else
Exit Do
End If
Loop
'check negative direction
r = rowNum - h
c = colNum - v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r - h
c = c - v
End If
Else
Exit Do
End If
Loop
End If
End If
Next h
Next v
Return 0 'Function has completed and no winner was found
'Return False <-- If only testing current player
End Function

Create BMP image with VBA

I tried to create a macro which converts value of cells into BMP file.
Code is based on existing topic, found here:
VBA manually create BMP
Type typHEADER
strType As String * 2 ' Signature of file = "BM"
lngSize As Long ' File size
intRes1 As Integer ' reserved = 0
intRes2 As Integer ' reserved = 0
lngOffset As Long ' offset to the bitmap data (bits)
End Type
Type typINFOHEADER
lngSize As Long ' Size
lngWidth As Long ' Height
lngHeight As Long ' Length
intPlanes As Integer ' Number of image planes in file
intBits As Integer ' Number of bits per pixel
lngCompression As Long ' Compression type (set to zero)
lngImageSize As Long ' Image size (bytes, set to zero)
lngxResolution As Long ' Device resolution (set to zero)
lngyResolution As Long ' Device resolution (set to zero)
lngColorCount As Long ' Number of colors (set to zero for 24 bits)
lngImportantColors As Long ' "Important" colors (set to zero)
End Type
Type typPIXEL
bytB As Byte ' Blue
bytG As Byte ' Green
bytR As Byte ' Red
End Type
Type typBITMAPFILE
bmfh As typHEADER
bmfi As typINFOHEADER
bmbits() As Byte
End Type
Sub testowy()
Dim bmpFile As typBITMAPFILE
Dim lngRowSize As Long
Dim lngPixelArraySize As Long
Dim lngFileSize As Long
Dim j, k, l, x As Integer
Dim bytRed, bytGreen, bytBlue As Integer
Dim lngRGBColoer() As Long
Dim strBMP As String
With bmpFile
With .bmfh
.strType = "BM"
.lngSize = 0
.intRes1 = 0
.intRes2 = 0
.lngOffset = 54
End With
With .bmfi
.lngSize = 40
.lngWidth = 21
.lngHeight = 21
.intPlanes = 1
.intBits = 24
.lngCompression = 0
.lngImageSize = 0
.lngxResolution = 0
.lngyResolution = 0
.lngColorCount = 0
.lngImportantColors = 0
End With
lngRowSize = Round(.bmfi.intBits * .bmfi.lngWidth / 32) * 4
lngPixelArraySize = lngRowSize * .bmfi.lngHeight
ReDim .bmbits(lngPixelArraySize)
ReDim lngRGBColor(21, 21)
For j = 1 To 21 ' For each row, starting at the bottom and working up...
'each column starting at the left
For x = 1 To 21
If Cells(j, x).Value = 1 Then
k = k + 1
.bmbits(k) = 0
k = k + 1
.bmbits(k) = 0
k = k + 1
.bmbits(k) = 0
Else
k = k + 1
.bmbits(k) = 255
k = k + 1
.bmbits(k) = 255
k = k + 1
.bmbits(k) = 255
End If
Next x
Next j
.bmfh.lngSize = 14 + 40 + lngPixelArraySize
End With ' Defining bmpFile
strBMP = "C:\Lab\xxx.BMP"
Open strBMP For Binary Access Write As 1 Len = 1
Put 1, 1, bmpFile.bmfh
Put 1, , bmpFile.bmfi
Put 1, , bmpFile.bmbits
Close
End Sub
The output differs significantly from my expectations (left - actual output, right - expected output).
There is a small error in code.
Colors at BMP file are saved as: [B,G,R] 1st pixel [B,G,R] 2nd pixel [0,0] padding (gap) for 4 byte alignment. To mirror the image the first loop should be reversed. The correct code (including loops) should be like:
k = -1
For j = 21 To 1 Step -1
' For each row, starting at the bottom and working up...
'each column starting at the left
For x = 1 To 21
If Cells(j, x).Value = 1 Then
k = k + 1
.bmbits(k) = 0
k = k + 1
.bmbits(k) = 0
k = k + 1
.bmbits(k) = 0
Else
k = k + 1
.bmbits(k) = 255
k = k + 1
.bmbits(k) = 255
k = k + 1
.bmbits(k) = 255
End If
Next x
If (21 * .bmfi.intBits / 8 < lngRowSize) Then ' Add padding if required
For l = 21 * .bmfi.intBits / 8 + 1 To lngRowSize
k = k + 1
.bmbits(k) = 0
Next l
End If
Next j

Simulation runs fine # 10k cycles, but gets error 13 (type mismatch) # 100k cycles

First off, here's my code:
Sub SimulatePortfolio()
Dim lambda As Double
Dim num As Integer
Dim cycles As Long
Column = 12
q = 1.5
lambda = 0.05
cycles = 100000
Dim data(1 To 100000, 1 To 10) As Integer
Dim values(1 To 10) As Double
For i = 1 To 10
values(i) = 0
Next i
temp = lambda
For i = 1 To cycles
lambda = temp
num = 10
t = 0
Dim temps(1 To 10) As Integer
For k = 1 To 10
temps(k) = 1000
Next k
Do While (t < 10 And num > 0)
t = t + tsim(lambda, num)
For j = 1 To 10
If (j > t) Then
temps(j) = temps(j) - 50
End If
Next j
num = num - 1
If (num <= 0) Then
Exit Do
End If
lambda = lambda * q
Loop
For l = 1 To 10
values(l) = values(l) + temps(l)
data(i, l) = temps(l)
Next l
Next i
For i = 1 To 10
Cells(i + 1, Column) = values(i) / cycles
'Problem occurs on this line:
Cells(i + 1, Column + 1).Value = Application.WorksheetFunction.Var(Application.WorksheetFunction.Index(data, i, 0))
Next i
End Sub
Function tsim(lambda As Double, num As Integer) As Double
Dim v As Double
Dim min As Double
Randomize
min = (-1 / lambda) * Log(Rnd)
For i = 1 To (num - 1)
Randomize
v = (-1 / lambda) * Log(Rnd)
If (min > v) Then
min = v
End If
Next i
tsim = min
End Function
When I set the value for cycles to 10000, it runs fine without a hitch. When I go to 100000 cycles, it gets an Error 13 at the indicated line of code.
Having been aware that Application.Tranpose is limited to 65536 rows with variants (throwing the same error) I tested the same issue with Index
It appears that Application.WorksheetFunction.Index also has a limit of 65536 rows when working with variants - but standard ranges are fine
So you will need to either need to dump data to a range and work on the range with Index, or work with two arrays
Sub Test()
Dim Y
Dim Z
'works in xl07/10
Debug.Print Application.WorksheetFunction.Index(Range("A1:A100000"), 1, 1)
Y = Range("A1:A65536")
`works
Debug.Print Application.WorksheetFunction.Index(Y, 1, 1)
'fails in xl07/10
Z = Range("A1:A65537")
Debug.Print Application.WorksheetFunction.Index(Z, 1, 1)
End Sub