Dim chessboard(7, 7) As Integer
For i = 0 To chessboard.GetUpperBound(0)
For j = 0 To chessboard.GetUpperBound(0)
If (i + j) mod 2 = Then
Console.out.Write(chessboard(i, j) = "B")
Else
Console.out.WriteLine(chessboard(i,j)="W")
End If
Next
Next
Console.in.ReadLine()
Because you are new at this...
Dim chessboard(7, 7) As String
For i As Integer = 0 To chessboard.GetUpperBound(0)
For j As Integer = 0 To chessboard.GetUpperBound(1)
If ((i + j) And 1) = 0 Then
chessboard(i, j) = "B"
Console.Write(chessboard(i, j))
Else
chessboard(i, j) = "W"
Console.Write(chessboard(i, j))
End If
Next
Console.WriteLine("")
Next
Related
I want to sort below Two-digit array by VBA code
A 1
B 2
A 1
C 3
or below:
1 A
2 B
1 A
3 C
I have tried to sort them by Dictionary, but, Dictionary is not allowed to insert duplate key.
Is there any want to sort above array by number 1,2,3
I made this some time ago, it might help.
Function ArraySorter(ByVal RecArray As Variant, Optional ByVal RefCol As Integer = 0) As Variant
Dim Menor As String
Dim NewArray() As Variant
Dim i As Double, j As Double
Dim menorIndex As Double
Dim NewArrayIndex() As Double
Dim UsedIndex() As Double
ReDim NewArrayIndex(UBound(RecArray, 2))
ReDim NewArray(UBound(RecArray), UBound(RecArray, 2))
For i = 0 To UBound(NewArrayIndex)
NewArrayIndex(i) = -1
Next i
UsedIndex = NewArrayIndex
For i = 0 To UBound(RecArray, 2)
Menor = ""
menorIndex = -1
For j = 0 To UBound(RecArray, 2)
If UsedIndex(j) = -1 Then
If Menor = "" Then
Menor = RecArray(RefCol, j)
menorIndex = j
Else
If RecArray(RefCol, j) < Menor Then
Menor = RecArray(RefCol, j)
menorIndex = j
End If
End If
End If
Next j
UsedIndex(menorIndex) = 1
NewArrayIndex(i) = menorIndex
Next i
For i = 0 To UBound(NewArrayIndex)
For j = 0 To UBound(NewArray)
NewArray(j, i) = RecArray(j, NewArrayIndex(i))
Next j
Next i
ArraySorter = NewArray
End Function
If you have something like:
Function testArraySorter()
Dim myArr() As Variant
ReDim myArr(1, 3)
myArr(0, 0) = "A"
myArr(0, 1) = "B"
myArr(0, 2) = "A"
myArr(0, 3) = "C"
myArr(1, 0) = 1
myArr(1, 1) = 2
myArr(1, 2) = 1
myArr(1, 3) = 3
myArr = ArraySorter(myArr)
For i = 0 To UBound(myArr, 2)
Debug.Print myArr(0, i), myArr(1, i)
Next i
End Function
you'll get this in your immediate verification :
A 1
A 1
B 2
C 3
If you need to sort based in two or more columns, you could add a dummy column into your array, concatenate the criteria columns into it and then set this dummy column as RefCol: myArr = ArraySorter(myArr, addedColNumberHere).
Hope this helps.
So I have a button to randomly pick a number from a range of 1 to 100 and place in a cell:
Public Sub RangeValue()
Dim i As Long
Static n As Long, s As String
Const MIN = 1, MAX = 100, OUT = "L10", DEL = "."
Randomize
Do
i = Rnd * (MAX - MIN) + MIN
If 0 = InStr(s, i & DEL) Then
n = n + 1: s = s & i & DEL
Range(OUT) = i
If n > MAX - MIN Then n = 0: s = ""
Exit Do
End If: DoEvents
Loop
End Sub
I want it to now pick 2 number from that range and place into two cells. I have tried:
Public Sub RangeValue()
Dim i As Long
Static n As Long, s As String
Const MIN = 1, MAX = 100, OUT = "L10""L11", DEL = "."
Randomize
Do
i = Rnd * (MAX - MIN) + MIN
If 0 = InStr(s, i & DEL) Then
n = n + 1: s = s & i & DEL
Range(OUT) = i
If n > MAX - MIN Then n = 0: s = ""
Exit Do
End If: DoEvents
Loop
End Sub
But it does not work. The goal is to have 2 numbers picked and put into 2 cells, and have them not repeat till all 100 numbers have been used.
I have not looked at your code closely but for the same you can also try code like below which is simpler to maintain and shall give similar results.
Sub RandomValues()
With Range("L10:L11")
.Formula = "=RANDBETWEEN(1,100)"
.Value = .Value
End With
End Sub
How about:
Public arr(1 To 100) As Variant
Sub ButtonCode()
If arr(1) = "" Then
For I = 1 To 100
arr(I) = I
Next I
Call Shuffle(arr)
Range("L10").Value = arr(1)
Else
N = Application.WorksheetFunction.Count(Range("L10:L" & Rows.Count))
Range("L10").Offset(N) = arr(N + 1)
End If
End Sub
Public Sub Shuffle(InOut() As Variant)
Dim I As Long, J As Long
Dim tempF As Double, Temp As Variant
Hi = UBound(InOut)
Low = LBound(InOut)
ReDim Helper(Low To Hi) As Double
Randomize
For I = Low To Hi
Helper(I) = Rnd
Next I
J = (Hi - Low + 1) \ 2
Do While J > 0
For I = Low To Hi - J
If Helper(I) > Helper(I + J) Then
tempF = Helper(I)
Helper(I) = Helper(I + J)
Helper(I + J) = tempF
Temp = InOut(I)
InOut(I) = InOut(I + J)
InOut(I + J) = Temp
End If
Next I
For I = Hi - J To Low Step -1
If Helper(I) > Helper(I + J) Then
tempF = Helper(I)
Helper(I) = Helper(I + J)
Helper(I + J) = tempF
Temp = InOut(I)
InOut(I) = InOut(I + J)
InOut(I + J) = Temp
End If
Next I
J = J \ 2
Loop
End Sub
This code will add values to the list starting with cell L10, without repeats.
EDIT#1:
This should be better:
Dim arr(1 To 100) As Variant
Dim clicks As Integer
Sub ButtonCode2()
If arr(1) = "" Then
For I = 1 To 100
arr(I) = I
Next I
Call Shuffle(arr)
Range("L10").Value = arr(1)
Range("L11").Value = arr(2)
clicks = 3
Else
Range("L10").Value = arr(clicks)
Range("L11").Value = arr(clicks + 1)
clicks = clicks + 2
End If
End Sub
(leave the Shuffle code as is)
I'm very new to VBA programming and in general in Excel macro.
Here it's the code that I made until now:
Private Sub GeneraTabella_Click()
Dim initialDate As Date
initialDate = Worksheets("Sheet1").Range("G1")
Dim MyArray() As Variant, NewMatrix(78, 4) As Integer
MyArray = Worksheets("Sheet1").Range("K1:N78").Value
Dim k, offset1, offset2 As Integer
Dim uguale As Boolean
For i = 1 To 10 Step 1
uguale = False
For j = 4 To 1 Step -1
k = 1
If uguale = True Then
'k = k + 1
j = j - k
uguale = False
End If
If j = 4 Then
offset1 = Abs(dateDiff("d", MyArray(i, j), initialDate))
NewMatrix(offset1, j) = NewMatrix(offset1, j) + 1
End If
If (j - k) <= 0 Then
GoTo continue
End If
offset1 = Abs(dateDiff("d", MyArray(i, j), initialDate))
offset2 = Abs(dateDiff("d", MyArray(i, j - k), initialDate))
'NewMatrix(offset1, j) = NewMatrix(offset1, j) + "+"
Do While offset1 = offset2
k = k + 1
uguale = True
If (j - k) <= 0 Then
uguale = False
GoTo continue
End If
'offset1 = Abs(dateDiff("d", MyArray(i, j), initialDate))
offset2 = Abs(dateDiff("d", MyArray(i, j - k), initialDate))
Loop
If offset1 <> offset2 Then
NewMatrix(offset1, j - k) = NewMatrix(offset1, j - k) - 1
NewMatrix(offset2, j - k) = NewMatrix(offset2, j - k) + 1
End If
If (j - k) = 1 Then
GoTo break
End If
continue:
Next j
break:
Next i
Worksheets("Sheet2").Range("A1:E78") = NewMatrix
End Sub
Why Worksheets("Sheet2").Range("A1:E78") = NewMatrix does not copy in Sheet2 from cell A1? It starts from cell B2.
If you have some tips to improve my vba styling code please tell me too.
Thanks in advance.
I'm trying VLookup until the cells in Column A are empty and it is not working and is returning Run-time error '1004' Unable to get the VLookup property of the WorksheetFunction class. Any help? Or is there a better loop that I can use.
Sub FindOldValue()
Dim oldvalue As String
Dim result As String
i = 2
j = 1
K = 2
l = 3
Do
oldvalue = Worksheets("Products").Cells(i, j) & Worksheets("Products").Cells(i, K) & "delete"
result = Application.WorksheetFunction.VLookup(oldvalue, Worksheets("Raw Delta").Range("A:H"), 7, 0)
Worksheets("Products").Cells(i, l) = result
i = i + 1
j = j + 1
K = K + 1
Loop Until Worksheets("Products").Cells(i, 1) = ""
End Sub
Have you tried using only Application.Vlookup instead of Application.Worksheetfunction.vlookup in the line
result = Application.WorksheetFunction.VLookup(oldvalue, Worksheets("Raw Delta").Range("A:H"), 7, 0)
?
How about changing the loop to something like this?
Do
oldvalue = Worksheets("Products").Cells(i, j) & Worksheets("Products").Cells(i, K) & "delete"
resultrow = Application.Match(oldvalue, Worksheets("Raw Delta").Columns(1), 0)
If Not IsError(resultrow) Then
Worksheets("Products").Cells(i, l) = Worksheets("Raw Delta").Cells(resultrow,7).Value
End If
i = i + 1
j = j + 1
K = K + 1
Loop Until Worksheets("Products").Cells(i, 1) = ""
I am trying to develop develop a model to calculate the sum of a cone to row 1 given an array of variable size only if the value of the cell is > 0.
If the sum is then >=1 I wish to color the range of the cone to display this. If the cone hits the A row boundary I need it not to error and for it to extend in the cone shape the other boundary. Here is what I have at the moment:
Public Sub MC()
Worksheets("SC").Cells.Clear
Dim i&, j&
For j = 1 To Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
If Worksheets("Data").Cells(i, j) > 0 Then
Worksheets("SC").Cells(i, j).Address , SumAndColorCone(Cells(i, j))
Else: If Worksheets("Data").Cells(i, j) <= 0 Then Worksheets("SC").Cells(i, j) = "0"
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
Try this:
Public Sub MC()
Dim c&, i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
c = RGB(Int(Rnd * 255) + 1, Int(Rnd * 255) + 1, Int(Rnd * 255) + 1)
Debug.Print "Testing value at: " & Cells(i, j).Address & vbLf & "Cone sum: " & SumAndColorCone(Cells(i, j), c) & vbLf
End If
Next
Next
End Sub
Private Function SumAndColorCone(r As Range, color&) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then
Set c = Union(c, r(-k, -r.Column + 2).Resize(, r.Column + k + 1))
Else
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
End If
k = k + 1
Next
SumAndColorCone = Application.Sum(c)
If SumAndColorCone > 1 Then c.Interior.color = color
End Function