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.
Related
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)
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
I have found a VBA script which is capable of making a distinction between two strings. For example A1 = aaabbb and B1 = aaabbbccc - it will highlight the ccc section in B1.
Since the report I am running this through has many rows I would like to loop it through a[i] and b[i]. I have tried adding standard loops though unfortunately it has consistently errored out.
Does anyone have experience adding loops to such a script?
Here is the script:
Public Sub FindDistinctSubstrings()
Dim a$, b$, i&, k&, rA As Range, rB As Range
Set rA = [a1]: a = rA
Set rB = [b1]: b = rB
k = Len(a): If Len(b) > k Then k = Len(b)
Do
i = i + 1
If Mid$(a, i, 1) <> Mid$(b, i, 1) Then
Align i, a, b, rA, rB
End If
DoEvents
Loop Until i > k
k = Len(a): If Len(b) > k Then k = Len(b)
For i = 1 To k
If Mid$(a, i, 1) = "." Then rB.Characters(i, 1).Font.Color = vbRed
If Mid$(b, i, 1) = "." Then rA.Characters(i, 1).Font.Color = vbRed
Next
Do
k = InStr(rA, "."): If k Then rA.Characters(k, 1).Delete
Loop Until k = 0
Do
k = InStr(rB, "."): If k Then rB.Characters(k, 1).Delete
Loop Until k = 0
End Sub
Private Sub Align(k&, a$, b$, rA As Range, rB As Range)
Dim i&, iMax&, nI&, nMaxI&, j&, jMax&, nJ&, nMaxJ&
Const LOOK_AHEAD_BUFFER = 30
For i = 0 To LOOK_AHEAD_BUFFER
nI = CountMatches(Space$(i) & Mid$(a, k, LOOK_AHEAD_BUFFER), Mid$(b, k, LOOK_AHEAD_BUFFER))
If nI > nMaxI Then
nMaxI = nI: iMax = i
End If
Next
For j = 0 To LOOK_AHEAD_BUFFER
nJ = CountMatches(Mid$(a, k, LOOK_AHEAD_BUFFER), Space$(j) & Mid$(b, k, LOOK_AHEAD_BUFFER))
If nJ > nMaxJ Then
nMaxJ = nJ: jMax = j
End If
Next
If nMaxI > nMaxJ Then
a = Left$(a, k - 1) & String$(iMax, ".") & Mid$(a, k)
rA = a: k = k + iMax
Else
b = Left$(b, k - 1) & String$(jMax, ".") & Mid$(b, k)
rB = b: k = k + jMax
End If
End Sub
Private Function CountMatches(a$, b$) As Long
Dim i&, k&, c&
k = Len(a): If Len(b) < k Then k = Len(b)
For i = 1 To k
If Mid$(a, i, 1) = Mid$(b, i, 1) Then c = c + 1
Next
CountMatches = c
End Function
Many thanks,
Sebastian
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
I'm trying to create a varcov matrix using VBA but despite hours of trying to track down the answer to this problem have been unable to solve it. My problem is that I keep getting the run-time error '9' on each of the below double-asterisked lines:
Sub varcovmmult()
Dim returns()
Dim trans()
Dim Excess()
Dim MMult()
ReDim trans(ColCount, RowCount)
ReDim Excess(RowCount, ColCount)
ReDim MMult(ColCount, ColCount)
ReDim returns(ColCount)
'Calculate mean, trans and excess arrays for dimensionalisation
'For mean:
ColCount = Range("C6:H15").Columns.Count
RowCount = Range("C6:H15").Rows.Count
For j = 1 To ColCount
**returns(j) = Application.Average(Range("C6:H15").Columns(j))
Range("c30:h30").Cells(j) = returns(j)**
Next j
'For excess:
For j = 1 To ColCount
For i = 1 To RowCount
**Excess(i, j) = Range("c6:h15").Cells(i, j) - returns(j)
Range("C36:H45").Cells(i, j) = Excess(i, j)**
Next i
Next j
'For tranpose:
For j = 1 To ColCount
For i = 1 To RowCount
**trans(j, i) = Range("C36:H45").Cells(i, j)
Range("C51:L56").Cells(j, i) = trans(j, i)**
Next i
Next j
'inject values into product array
For i = 1 To ColCount
For j = 1 To ColCount
For k = 1 To RowCount
**MMult(i, j) = MMult(i, j) + trans(i, k) * Excess(k, j)**
Next k
Next j
Next i
'output product array values into varcov matrix and divide by n.years
For i = 1 To ColCount
For j = 1 To ColCount
**Range("C62").Cells(i, j) = MMult(i, j)**
Next j
Next i
End Sub
You need to put these lines:
ReDim trans(ColCount, RowCount)
ReDim Excess(RowCount, ColCount)
ReDim MMult(ColCount, ColCount)
ReDim returns(ColCount)
After these lines:
ColCount = Range("C6:H15").Columns.Count
RowCount = Range("C6:H15").Rows.Count
I am trying to run the following code with value 1 in each cell in Range(C6:H15):
Sub varcovmmult()
Dim returns()
Dim trans()
Dim Excess()
Dim MMult()
ColCount = Range("C6:H15").Columns.Count
RowCount = Range("C6:H15").Rows.Count
ReDim trans(ColCount, RowCount)
ReDim Excess(RowCount, ColCount)
ReDim MMult(ColCount, ColCount)
ReDim returns(ColCount)
For j = 1 To ColCount
returns(j) = Application.Average(Range("C6:H15").Columns(j))
Range("c30:h30").Cells(j) = returns(j)
Next j
For j = 1 To ColCount
For i = 1 To RowCount
Excess(i, j) = Range("c6:h15").Cells(i, j) - returns(j)
Range("C36:H45").Cells(i, j) = Excess(i, j)
Next i
Next j
For j = 1 To ColCount
For i = 1 To RowCount
trans(j, i) = Range("C36:H45").Cells(i, j)
Range("C51:L56").Cells(j, i) = trans(j, i)
Next i
Next j
For i = 1 To ColCount
For j = 1 To ColCount
For k = 1 To RowCount
MMult(i, j) = MMult(i, j) + trans(i, k) * Excess(k, j)
Next k
Next j
Next i
For i = 1 To ColCount
For j = 1 To ColCount
Range("C62").Cells(i, j) = MMult(i, j)
Next j
Next i
End Sub
I am successfully able to run this code.
One error that I get was Type mismatch if value in any cell in this range is blank or non-numeric.
If you're getting subscript out of range then you may try using ColCount - 1 or RowCount - 1. Just check if appropriate value exists in Cell(i, j).
Hope this helps!
Vivek