I am trying to capture a table via an array, and iterate through the array multiple times, changing the data in two columns through each iteration. My current code (below) is set up to iterate through the array once, changing the data in two sections (, 5) and (, 6). Unfortunately, it displays an error reading
Run-time error '9': Subscript out of range
Sub arraytest()
Dim myArray As Variant
myArray = ActiveWorkbook.Worksheets("Semesters").ListObjects("tblSemester").DataBodyRange.Value
Dim i As Integer
Dim Roww As Integer
Roww = 1
While i < 10
For Each r In myArray
myArray(i, 5) = "18/19"
myArray(i, 6) = "Fall"
Roww = Roww + 1
i = 10
Next
Wend
Worksheets("Sheet1").Range("A2", "U2").Resize(UBound(myArray, 1)).Value = myArray
End Sub
How to I edit the code to successfully iterate through the array, changing the data on the specific columns?
I think you want this:
Sub arraytest()
Dim myArray As Variant
Dim i As Integer
myArray = ActiveWorkbook.Worksheets("Semesters").ListObjects("tblSemester").DataBodyRange.Value
For i = 1 To UBound(myArray, 1)
myArray(i, 5) = "18/19"
myArray(i, 6) = "Fall"
Next
Worksheets("Sheet1").Range("A2").Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
Related
Fairly new to Arrays (im trying to speed up a currently slow workbook that uses ranges)
lets say I start out with a table like this (Located in Range "A1:B5" on my worksheet)
and im trying to filter it to only intact (this is a simplified version of what im trying to do irl), why am I getting a Type Mismatch and my output array highlighting?
Public Sub Manager_Report()
'Declare Variables
Dim main_array As Variant Dim output_array As Variant
'Populate Main Array
main_array = range("A1").CurrentRegion
'Filter the Array for intact
output_array = Filter(main_array, "Intact")
End Sub
Option Explicit
Option Base 1
Sub OutputFilterArray()
Dim INarray
Dim OutArray
Dim OutArrayFinal
Dim I As Long
Dim CNT As Long
Dim N As Integer
INarray = Range("A3:d" & Range("d" & Rows.Count).End(xlUp).Row).Value
CNT = 1
ReDim OutArray(UBound(INarray, 1), UBound(INarray, 2))
For I = 1 To UBound(INarray, 1)
If INarray(I, 1) = "Intact" Then
For N = 1 To UBound(INarray, 2)
OutArray(CNT, N) = INarray(I, N)
Next N
CNT = CNT + 1
End If
Next I
Range("F3").Resize(UBound(OutArray, 1), UBound(OutArray, 2)) = OutArray
End Sub
This should be easy and I think I am almost there. I would like to count how many times an entry repeats itself within a certain array. The array will be populated from a range. Eventually if the number of the count is more than 4, I would like to insert "Excess", otherwise if less than 4, I would like to insert "Insufficient", else is "complete". Unfortunately, even though I have learnt to do these calculations without using Arrays, I find some difficulties when switching to Arrays.
How the code should look like
Sub test()
Dim MyArray() As Variant, Countarrays() As Variant, Result() As Variant
Dim r As Range
Dim rows As Integer
Worksheets("Sheet1").Activate
Set r = Range("B2", Range("B1").End(xlDown))
MyArray = Range("B2", Range("B1").End(xlDown))
rows = Range("B2", Range("B1").End(xlDown)).Count
For i = 0 To rows
For j = 0 To rows
Countarrays(i, 1) = WorksheetFunction.CountIf(r, MyArray(i))
If (Countarrays(i, 1).value) > 4 Then Result(j, 1) = "Excess"
ElseIf (Countarrays(i, 1).value) < 4 Then Result(j, 1) = "Insufficient"
ElseIf (Countarrays(i, 1).value) = 4 Then Result(j, 1) = "Complete"
Next j
Next i
End Sub
This should do the trick:
Option Explicit
Sub Test()
Dim MyArray, DictDuplicates As New Scripting.Dictionary, i As Long
With ThisWorkbook.Sheets("Sheet1") 'change if needed
MyArray = .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown))
For i = LBound(MyArray) To UBound(MyArray) 'loop to store all the items and how many times do they repeat
If Not DictDuplicates.Exists(MyArray(i, 2)) Then 'if doesn't exists will store it
DictDuplicates.Add MyArray(i, 2), 1
Else 'if it does exists will increment its item value
DictDuplicates(MyArray(i, 2)) = DictDuplicates(MyArray(i, 2)) + 1
End If
Next i
For i = LBound(MyArray) To UBound(MyArray) 'loop to give back the result
Select Case DictDuplicates(MyArray(i, 2))
Case Is > 4
MyArray(i, 1) = "Excess"
Case Is = 4
MyArray(i, 1) = "Complete"
Case Is < 4
MyArray(i, 1) = "Insufficient"
End Select
Next i
.Range(.Cells(2, 1), .Cells(2, 2).End(xlDown)) = MyArray
End With
End Sub
Note that for the DictDuplicates to work, you need to check the Microsoft Scripting Runtime library.
I'm writing a sub in VBA that is trying to look at each element in one array and see if it shows up in another array. The first array is in rows A2:A325 in Sheet A, and the second array is over 250,000 values. I keep getting a runtime error 9: subscript out of range. My code is below
Private Sub ICD_DRG_Converter()
Dim StudyDRG() As Variant
Dim StudyICD10() As Variant
Dim element As String
Dim lLastRow, i, j, k As Long
Dim ICD10Code As String
Worksheets("Accepted DRG's").Activate
ReDim StudyDRG(1 To 325) As Variant
StudyDRG = Range("A2:A325") 'Populate the study DRG's into an array for comparison
Worksheets("full_appendix_B").Activate
lLastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row 'get the last row of data for sizing our ICD 10 array
ReDim StudyICD10(1 To (lLastRow)) As Variant
StudyICD10 = Range("B2:B" & lLastRow)
'i = 0
For i = LBound(StudyICD10) To UBound(StudyICD10)
k = 1
For j = LBound(StudyDRG) To UBound(StudyDRG)
If StrComp(StudyICD10(i), StudyDRG(j), vbBinaryCompare) = 0 Then 'match between study DRG and ICD-10 DRG
Worksheets("full_appendix_B").Activate
ICD10Code = Range("A" & j).Value
Worksheets("Accepted ICD-10").Activate
Range("A" & k) = ICD10Code
k = k + 1
Exit For
End If
Next j
Next i
End Sub
The line that generates the error is:
If StrComp(StudyICD10(i), StudyDRG(j), vbBinaryCompare) = 0 Then
Any help on how to fix this would be appreciated. I've tried everything I know
When you use Range() to return a range of values into a variant array, the array is resized to match the range. So the results of
ReDim StudyDRG(1 To 325) As Variant
StudyDRG = Range("A2:A325")
is that studyDRG will have elements from 1 to 324, not 1 to 325.
Not only that, but Range() always returns a two dimensional array, even if there's only one column. So to refer to the element that corresponds to A2, you need to use StudyDRG(1,1), and A3 would be StudyDRG(1,2).
I hope this helps.
I'm having troubles getting my Error array to print to a range. I'm fairly sure I'm resizing it incorrectly, but I'm not sure how to fix it. I created a test add which just added garbage data from columns A and B, but normally AddPartError would be call from within various Subs/Functions, and then at the end of the main script process the array should be dumped onto a sheet. Here are the relevant functions:
Sub testadd()
For Each i In ActiveSheet.Range("A1:A10")
Call AddPartError(i.value, i.Offset(0, 1))
Next i
tmp = PartErrors
PrintArray PartErrors, ActiveWorkbook.Worksheets("Sheet1").[D1]
Erase PartErrors
tmp1 = PartErrors
PartErrorsDefined = 0
End Sub
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), 2) = Data
End Sub
Private Sub AddPartError(part As String, errType As String)
If Not PartErrorsDefined = 1 Then
ReDim PartErrors(1 To 1) As Variant
PartErrorsDefined = 1
End If
PartErrors(UBound(PartErrors)) = Array(part, errType)
ReDim Preserve PartErrors(1 To UBound(PartErrors) + 1) As Variant
End Sub
Ok. I did a bit of checking and the reason this doesn't work is because of your array structure of PartErrors
PartErrors is a 1 dimensional array and you are adding arrays to it, so instead of multi dimentional array you end up with a jagged array, (or array of arrays) when you actually want a 2d array
So to fix this, I think you need to look at changing your array to 2d. Something like the below
Private Sub AddPartError(part As String, errType As String)
If Not PartErrorsDefined = 1 Then
ReDim PartErrors(1 To 2, 1 To 1) As Variant
PartErrorsDefined = 1
End If
PartErrors(1, UBound(PartErrors, 2)) = part 'Array(part, errType)
PartErrors(2, UBound(PartErrors, 2)) = errType
ReDim Preserve PartErrors(1 To 2, 1 To UBound(PartErrors, 2) + 1) As Variant
End Sub
and
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 2), 2) = Application.Transpose(Data)
End Sub
NB. You also need to Transpose your array to fit in the range you specified.
You code is a little hard to follow, but redim clears the data that is in the array, so I think you need to use the "Preserve" keyword.
Below is some example code you can work through to give you the idea of how it works, but you will need to spend some time working out how to fit this into your code.
Good luck!
Sub asda()
'declare an array
Dim MyArray() As String
'First time we size the array I do not need the "Preserve keyword
'there is not data in the array to start with!!!
'Here we size it too 2 by 5
ReDim MyArray(1, 4)
'Fill Array with Stuff
For i = 0 To 4
MyArray(0, i) = "Item at 0," & i
MyArray(1, i) = "Item at 1," & i
Next
' "Print" data to worksheet
Dim Destination1 As Range
Set Destination1 = Range("a1")
Destination1.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).Value = MyArray
'Now lets resize that arrray
'YOU CAN ONLY RESIZE THE LAST SIZE OF THE ARRAY - in this case 4 to 6...
ReDim Preserve MyArray(1, 6)
For i = 5 To 6
MyArray(0, i) = "New Item at 0," & i
MyArray(1, i) = "New Item at 1," & i
Next
'and let put that next to our first list
' "Print" data to worksheet
Dim Destination2 As Range
Set Destination2 = Range("A4")
Destination2.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).Value = MyArray
End Sub
I'm trying to cumulate the sums of values in an excel column of 4 values dimension (4,1).
So, I constructed the code below. For the first row in a column on the side Result, it is supposed to hold the same value as in the original Array.
But then, once it is greater than the first row, it is supposed to get the previous element of result (i-1) and add to it the current column element (i).
VBA is telling me that the subscript is out of range :/ and I cant figure out why... so I dont even know if my code does what I want.
Sub CumulativeSum()
Dim i As Integer
Dim j As Integer
Dim rColumn() As Variant
Dim result() As Variant
ReDim result(1 To 4)
rColumn = Worksheets("Sheet1").Range("E1:E4").Value2
For i = 1 To 4
result(1) = rColumn(1, 1)
For j = 2 To 3
result(j) = rColumn(j, 1) + result(j - 1)
Next j
Next i
Dim dest As Range
Set dest = Worksheets("Sheet1").Range("F1")
dest.Resize(4, 1).Value = result
End Sub
Sub CumulativeSum()
Dim dest As Range
Dim i As Integer
Dim j As Integer
Dim rColumn() As Variant
Dim result() As Variant
ReDim result(1 To 4)
rColumn = Worksheets("Sheet1").Range("E1:E4").Value2
result(1) = rColumn(1, 1)
For j = 2 To 4
result(j) = rColumn(j, 1) + result(j - 1)
Next j
Set dest = Worksheets("Sheet1").Range("F1")
dest.Resize(4, 1).Value = Application.Transpose(result)
End Sub
Don't have enough rep to add a comment but.. the reason why you're getting an error is because the Syntax for Cells is Cells([Row],[Column]). You're typing it in as Cells([Column],[Row]).
Try Range(Cells(1, 5), Cells(4, 5)) instead.