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
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.
Suppose I have a column of values
1
2
3
4
5
I'm trying to write a VBA function where based on what number I chose(n)
the cells will loop around to that position. So say I i chose 3
Then new list will be
4
5
1
2
3
What I have done is based on each row number, I have tried to develop rules to move the cells but it doesn't seem to be working.. I suspect it's cause I'm using activerow and not the relative row position, but I'm not sure what the syntax is for relative row. Can someone help me out
Option Explicit
Option Base 1
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Integer, j As Integer
Dim nr As Integer, nc As Integer
Dim B() As Variant
Dim r As ListRow
nr = rng.Rows.Count
nc = rng.Columns.Count
r = ActiveCell.Row
ReDim B(nr, nc) As Variant
For i = 1 To nr
For j = 1 To nc
If r = 1 And r < n Then
B(nr - (n - 1), j) = rng.Cells(i, j)
ElseIf r > 1 And r < n Then
B(nr - (n - r), j) = rng.Cells(i, j)
ElseIf r > n Then
B(r - n, j) = rng.Cells(i, j)
ElseIf r = n Then
B(r, j) = rng.Cells(i, j)
End If
Next j
Next i
DivisibleByN = B
End Function
Assuming you want to "roll" each column individually, you can do something like this:
Public Sub RollColumns(ByVal rng As Range, ByVal rollBy As Integer)
Dim rowsCount As Integer, colsCount As Integer
Dim rowsOffset As Integer, colsOffset As Integer
Dim r As Integer, c As Integer
rowsCount = rng.Rows.Count
colsCount = rng.Columns.Count
rowsOffset = rng.Rows(1).Row - 1
colsOffset = rng.Columns(1).Column - 1
If rowsCount = 1 Then Exit Sub
Dim arr As Variant
arr = rng.Value
For c = 1 To colsCount
For r = 1 To rowsCount
Dim targetIndex As Integer
targetIndex = (r + rollBy) Mod rowsCount
If targetIndex = 0 Then targetIndex = rowsCount
rng.Worksheet.Cells(r + rowsOffset, c + colsOffset).Value = _
arr(targetIndex, c)
Next r
Next c
End Sub
Usage:
RollColumns Range("A1:C5"), 3
See it in action:
you could use this
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Long, j As Long
With rng
ReDim B(0 To .Rows.Count - 1, 0 To .Columns.Count - 1) As Variant
For i = .Rows.Count To 1 Step -1
For j = 1 To .Columns.Count
B(i - 1, j - 1) = .Cells((.Rows.Count + i - (n + 1)) Mod .Rows.Count + 1, j)
Next
Next
DivisibleByN = B
End With
End Function
This was just to mess around with COM objects and explore them... could be tidied up. S&G moment.
Option Explicit
Public Sub test()
Const n As Long = 3 '<==Add your end point here
Dim arr(), i As Long, rng As Range
With ThisWorkbook.Worksheets("Sheet6") '<==Put your sheet name here
Set rng = .Range("A1:A5") '<== Add your single column range here
Dim maxValue As Variant
Dim minValue As Variant
maxValue = Application.Max(rng)
minValue = Application.Min(rng)
If IsError(maxValue) Or IsError(minValue) Then Exit Sub
If n > maxValue Or n < minValue Then Exit Sub
If rng.Columns.Count > 1 Then Exit Sub
If rng.Cells.Count = 1 Then
ReDim arr(1, 1): arr(1, 1) = rng.Value
Else
arr = rng.Value
End If
Dim list As Object, list2 As Object, queue As Object, arr2()
Set list = CreateObject("System.Collections.ArrayList")
Set queue = CreateObject("System.Collections.Queue")
For i = LBound(arr, 1) To UBound(arr, 1)
list.Add arr(i, 1)
Next
list.Sort
Set list2 = list.Clone
list2.Clear
arr2 = list.GetRange(n, maxValue - n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
queue.Clear
arr2 = list.GetRange(0, n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
rng.Cells(1, 1).Resize(list2.Count, 1) = Application.WorksheetFunction.Transpose(list2.toArray)
End With
End Sub
Is there someone can help me? I have here code that can duplicate entire row to have 2 rows. After duplicating the first entire row , I want to load string from range "G" into array so that I can get certain string that Am planning to insert in "Thickness" and "width" column for me to use to calculate the "Weight" of the "Profile Type". If you will see I have an array in the code .But that array work differently for me and I had a hard time fulfilling the requirements I need. The array in my code split the String using "X" as delimiter . Once the string was split it will add another cells for each split string. what I want is to do the split not in the column but in the array only so that I can maintain the data in G . I will use the string assigned in the array to get "Thickness and Width" of the profile which is "15 as Thickness and 150 as width". If there's any way to do same thing using other code it will be more helpful to simplify the code.
Reminder that Profiletype string vary its length . Sometimes profile width are 4 digits (LB1000X4500X12/15)
Below are the snapshot of my worksheet for you to identify what the result will be.
Private Sub CommandButton2_Click()
Dim lastrow As Long
Dim i As Integer
Dim icount As Integer
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
'array
'Columns("G:G").NumberFormat = "#"
Dim c As Long, r As Range, v As Variant, d As Variant
For i = 2 To Range("G" & Rows.Count).End(xlUp).Row '2 to 16 cell
'v = Split (range("G" & i), "X")
v = Split((Cells(x, "G") & i), "x")
c = c + UBound(v) + 1
'Next i
For i = 2 To c
If Range("G" & i) <> "" Then
Set r = Range("G" & i)
Dim arr As Variant
arr = Split(r, "X")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert Shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, -2) = r.Offset(0, -2)
Next j
End If
Next i
End If
Next x
End Sub
Does this do what you want? Run in copy of workbook to be safe.
Option explicit
Private Sub CommandButton2_Click()
'Bit redundant, would be better if you fully qualify workbook and worksheet with actual names.'
Dim TargetWorksheet as worksheet
Set TargetWorksheet = Activesheet
With application
.screenupdating = false
.calculation = xlcalculationmanual
End with
With TargetWorksheet
.range("G:G").numberformat = "#"
Dim RowIndex As Long
For RowIndex = .usedrange.rows.countlarge to 1 step -1
If .Cells(RowIndex, "F").value2 = "LB" Then
.Cells(RowIndex, "F").value2 = "ComP"
.Cells(RowIndex + 1, "F").EntireRow.Insert
.Cells(RowIndex, "F").EntireRow.Copy .Cells(RowIndex + 1, "F").EntireRow
Dim SplitProfileType() as string
SplitProfileType = split(mid(.cells(RowIndex+1,"G").value2,3), "X") ' assumes first two characters will always be LB, that it is safe to ignore them and start from third character.'
' Write thickness'
.cells(RowIndex+1, "H").value2 = cdbl(mid(SplitProfileType(ubound(SplitProfileType)),instrrev(SplitProfileType(ubound(SplitProfileType)),"/",-1,vbbinarycompare)+1)
' Write width'
.cells(RowIndex+1, "i").value2 = cdbl(SplitProfileType(1))
' Calculate weight'
.cells(RowIndex+1,"K").value2 = .cells(RowIndex+1,"H").value2 * .cells(RowIndex+1,"I").value2 * .cells(RowIndex+1,"J").value2
End if
' I think because you are inserting a row below (rather than above/before), your RowIndex remains unaffected and no adjustment is needed to code. I could be wrong. I would need to test it to be sure.'
Next rowindex
End with
With application
.screenupdating = true
.calculation = xlcalculationautomatic
End with
End sub
Untested as written on mobile.
It works without duplication.
Sub test2()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim r As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
For i = 1 To n
If vDB(i, 6) = "LB" Then
r = 2
Else
r = 1
End If
k = k + r
ReDim Preserve vR(1 To 11, 1 To k)
s = vDB(i, 7)
For j = 1 To 11
If r = 1 Then
vR(j, k) = vDB(i, j)
Else
vR(j, k - 1) = vDB(i, j)
vR(j, k) = vDB(i, j)
End If
Next j
If r = 2 Then
vR(6, k - 1) = "comp"
vR(6, k) = "comp"
vR(8, k) = Split(s, "/")(1)
vR(9, k) = Split(s, "X")(1)
vR(9, k - 1) = vR(9, k - 1) - vR(8, k)
vR(11, k - 1) = (vR(8, k - 1) * vR(9, k - 1) * vR(10, k - 1) * 7.85) / 10 ^ 6 '<~~ k2 weight
vR(11, k) = (vR(8, k) * vR(9, k) * vR(10, k) * 7.85) / 10 ^ 6 '<~~ k3 weight
End If
Next i
Range("f1") = "Type"
Range("a2").Resize(k, 11) = WorksheetFunction.Transpose(vR)
End Sub
It is faster to use an array than to enter it one-to-one in a cell.
Sub test()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
ReDim vR(1 To n * 2, 1 To 11)
For i = 1 To n
k = k + 2
s = vDB(i, 7)
For j = 1 To 11
vR(k - 1, j) = vDB(i, j)
vR(k, j) = vDB(i, j)
Next j
vR(k - 1, 6) = "comp"
vR(k, 6) = "comp"
vR(k, 8) = Split(s, "/")(1)
vR(k, 9) = Split(s, "X")(1)
vR(k, 11) = Empty '<~~ This is calculated Weight value place
Next i
Range("f1") = "Type"
Range("a2").Resize(n * 2, 11) = vR
End Sub
Column A has numbers from 0 to 5. When there is a number greater than 0, I want it to generate that number of random numbers in the columns next to that cell.
For example if A4 = 3, then I want a random numbers in B4,C4 and D4.
I have the following code that works fine in picking up values over 0 and generating a random number between 200 and 300 but I am stuck on how to have it generate more than one.
Can anyone point me in the right direction? thank you
Sub RandomNumbers()
Dim i As Integer
Dim j As Integer
Dim lastrow As Integer
lastrow = Range("a1").End(xlDown).Row
For j = 1 To 1
For i = 1 To lastrow
If ThisWorkbook.Sheets("LossFrequency").Cells(i, j).Value > 0 Then
ThisWorkbook.Sheets("LossFrequency").Cells(i, j + 1).Value = Int((300 - 200 + 1) * Rnd + 200)
Else: ThisWorkbook.Sheets("LossFrequency").Cells(i, j + 1).Value = 0
End If
Next i
Next j
End Sub
You have your loops switched:
Sub RandomNumbers()
Dim i As Integer
Dim j As Integer
Dim lastrow As Integer
lastrow = Range("a1").End(xlDown).Row
With ThisWorkbook.Sheets("LossFrequency")
For i = 1 To lastrow
If .Cells(i, 1).Value > 0 Then
For j = 1 To .Cells(i, 1).Value
.Cells(i, j + 1).Value = Int((300 - 200 + 1) * Rnd + 200)
Next j
Else
.Cells(i, 2).Value = 0
End If
Next i
End With
End Sub
Sub RandomNumbers()
Dim i As Integer
Dim j As Integer
Dim lastrow As Integer
Dim iValue As Integer
Dim iColCount As Integer
j = 1
lastrow = Range("a1").End(xlDown).Row
For i = 1 To lastrow
iValue = ThisWorkbook.Sheets("LossFrequency").Cells(i, j).Value
If iValue > 0 Then
For iColCount = 1 To iValue
ThisWorkbook.Sheets("LossFrequency").Cells(i, iColCount + 1).Value = Int((300 - 200 + 1) * Rnd + 200)
Next iColCount
Else
ThisWorkbook.Sheets("LossFrequency").Cells(i, j + 1).Value = 0
End If
Next i
End Sub
here's a formula approach
Sub RandomNumbers()
Dim cell As Range
With ThisWorkbook.Sheets("LossFrequency")
For Each cell In .Range("A1", .Cells(.Rows.count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
If cell.Value = 0 Then
cell.Offset(, 1).Value = 0
Else
cell.Offset(, 1).Resize(, cell.Value).FormulaR1C1 = "=RandBetween(300,200)"
End If
Next
End With
End Sub
I don't know what I am doing wrong as the code below is able to ReDim Preserve the first iteration but not the second.
Dim inj0() As Variant
Dim i As Integer
Dim c As Integer
Dim Rng As Range
Dim pos As Integer
'Find the last used column in a Row
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
c = 0
For i = 1 To LastCol
pos = InStr(Cells(2, i), "80")
If pos = 1 Then
ReDim Preserve inj0(c, 2)
inj0(0, 1) = "80"
Set Rng = Cells(2, i)
inj0(c, 2) = Rng.Offset(-1, 0).Value
inj0(c, 0) = Rng.Offset(3, 0).Value
c = c + 1
End If
Next
Try to change the code as follows:
c = 0
ReDim inj0(2, 0)
inj0(1, 0) = "80"
For i = 1 To LastCol
pos = InStr(Cells(2, i), "80")
If pos = 1 Then
ReDim Preserve inj0(2, c)
Set Rng = Cells(2, i)
inj0(2, c) = Rng.Offset(-1, 0).Value
inj0(0, c) = Rng.Offset(3, 0).Value
c = c + 1
End If
Next
If you need the dimensions to be swapped, finally you can apply WorksheetFunction.Transpose method.