Why does this:
Dim Arr As Variant
p = 1
For i = 1 To LRow
If Sheets("Data").Range("U" & 4 + i).Value > 0 Then
ReDim Preserve Arr(1 To p, 1 To 2)
Arr(p, 1) = Sheets("Data").Range("U" & 4 + i).Value
Arr(p, 2) = Sheets("Data").Range("N" & 4 + i).Value
p = p + 1
End If
Next
results in "run time error 9 - Subscript out of range" at the ReDim line?
I do not know the number of array rows prior to entering the for loop. The column number should always be 2. Doing the same thing but with an 1D Array works, though!
Any help?
As stated, you can only redim preserve the last dimension.
But you can also use other methods to find the number of "rows" needed and set that prior to rediming the array:
Dim Arr As Variant
p = 1
dim rws as long
rws = Application.WorkSheetFunction.CountIf(Sheets("Data").Range("U5:U" & Lrow+4),">0")
Redim Arr(1 to rws,1 to 2)
For i = 1 To LRow
If Sheets("Data").Range("U" & 4 + i).Value > 0 Then
Arr(p, 1) = Sheets("Data").Range("U" & 4 + i).Value
Arr(p, 2) = Sheets("Data").Range("N" & 4 + i).Value
p = p + 1
End If
Next
If you use ReDim Preserve you can only resize the last dimension of an array.
See here:https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/redim-statement
If you are looking for a solution, then you can swap array to be Arr(2,p) as you say column number will always be 2.
Related
Could someone explain my why my code display values at columns instead of rows ? Thanks
Function ShiftVector(rng As Range, n As Integer)
Dim i As Integer
Dim j As Integer
Dim B As Variant
Dim A() As Variant
Dim nr As Integer
nr = rng.Rows.Count
ReDim B(nr)
ReDim A(nr)
For i = 1 To nr - n
B(i) = rng(i + n)
Next i
For i = nr - n + 1 To nr
B(i) = rng(i - nr + n)
Next i
ShiftVector = B
End Function
Your code loads a 1D array, which does not have rows by definition... Then, you do not explain what n means and I will make abstraction of its 'contribution' in the function... The next interpretation assumes that rng is a range containing only a column.
There are two ways of solving it:
Let the code as it is, but finally use:
ShiftVector = Application.Transpose(B)
ReDim and load a 2D array:
ReDim B(1 to nr, 1 to 1)
'and load it in the next way:
B(i, 1) = rng(i + n)
You can place a range directly in a (2D) array:
B = rng.value
If you will explain what n wants to be, I can adapt the answer to somehow take it in consideration...
Edited:
Please, play with the next function, able to make slices from a 2D array and 'mount' them in a different order:
Function ShiftVector2D(rng As Range, n As Integer) As Variant
Dim nr As Long, arr, arrSl1, arrSl2
nr = rng.rows.count - rng.row + 1 'the number of the range rows, even if it does not start from the first row...
arr = rng.Value 'place the range in a 2D array
With Application
arrSl1 = .Index(arr, Evaluate("row(1:" & n & ")"), 1) 'obtain an array slice of the first n rows
arrSl2 = .Index(arr, Evaluate("row(" & n + 1 & ":" & nr & ")"), 1) 'obtain an array slice of the rows after n up to the last row
arr = Split(Join(.Transpose(arrSl2), "|") & "|" & Join(.Transpose(arrSl1), "|"), "|") 'created a 1 D array by joinning the two arrays and split them by "|"
ShiftVector2D = .Transpose(arr) 'return the 2D necessary shifted array
End With
End Function
You can test it placing some strings in the range "A1:A10" and run the next code:
Sub testShiftVector2D()
Dim rng As Range, arr
Set rng = Range("A1:A10")
arr = ShiftVector2D(rng, 4)
Debug.Print Join(Application.Transpose(arr), "|")
End Sub
Suppose I have a VBA one dimension array (or dict or collection) with X values. I need to perform an action with these values in batches of Y.
So if X = 55 and Y = 25, I would need to loop 3 times:
Pick values 1 to 25 and perform action
Pick values 26 to 50 and perform action
Pick last 5 values and perform action
Any ideas with good performance will be greatly appreciated :)
Edit:
I came up with the code below. It works although doesn't look very concise
Sub test()
Dim arr As Variant
Dim temparr As Variant
Dim sippno As Integer
Dim loopend As Integer
Dim loopstart As Integer
Dim batchsize As Integer
Dim i As Integer
'Storing main array with all values
arr = Sheet1.Range("A1:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Value
'Setting count of values, batch size and starting step for loop
sippno = WorksheetFunction.CountA(arr)
loopstart = 1
batchsize = 10
Do Until sippno = 0
If sippno < batchsize Then
loopend = loopstart + sippno - 1
Else
loopend = loopstart + batchsize - 1
End If
ReDim temparr(loopstart To loopend)
For i = loopstart To loopend
temparr(i) = WorksheetFunction.Index(arr, i, 0)
sippno = sippno - 1
Next
loopstart = loopend + 1
'Action to be performed with batch of values stored in second array
Debug.Print WorksheetFunction.TextJoin(", ", True, temparr)
Loop
End Sub
Slicing via Application.Index()
Just for the sake of the art I demonstrate in this late post how to slice a 'vertical' array in one go into several 'flat' arrays in batches of e.g. 10 elements.
This approach benefits from the advanced rearranging features & pecularities of Application.Index()
allowing to pass entire row/column number arrays as arguments; here suffices a vertical array of desired row numbers, e.g. by filtering only rows 11 to 20 via Application.Index(data, Evaluate("Row(11:20)"), 0). .. c.f. see section 2 a)
Further notes:
evaluating a tabular row formula is one quick way to get consecutive row numbers.
transposing the function result changes the array dimension to a 1-dim array
reducing the array boundaries by -1 via ReDim Preserve ar(0 To UBound(ar) - 1) produces a zero-based array (optional)
Option Explicit
Sub splice()
Const batch = 10 ' act in units of 10 elements
With Sheet1
'1) get data (1-based 2-dim array)
Dim lastRow As Long
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim data: data = .Range("A1:A" & lastRow).Value2
'2) slice
Dim i As Long, nxt As Long, ar As Variant
For i = 1 To UBound(data) Step batch
nxt = Application.min(i + batch - 1, UBound(data))
'2a) assign sliced data to 1- dim array (with optional redim to 0-base)
With Application
ar = .Transpose(.Index(data, Evaluate("row(" & i & ":" & nxt & ")")))
End With
'optional redimming to zero-base
ReDim Preserve ar(0 To UBound(ar) - 1)
'2b) perform some action
Debug.Print _
"batch " & i \ batch + 1 & ": " & _
"ar(" & LBound(ar) & " To " & UBound(ar) & ") ~~> " & _
Join(ar, "|")
Next
End With
End Sub
Slicing a 'flat' 1-dim array
If, however you want to slice a 1-dim array, like e.g. dictionary keys, it suffices to transpose the data input: data = Application.Transpose(...)
Option Explicit
Sub splice()
Const batch = 10
Dim data, ar()
Dim lastrow As Long, n As Long, i As Long
Dim j As Long, r As Long
With Sheet1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
data = .Range("A1:A" & lastrow).Value2
End With
i = Int(lastrow / batch)
For n = 0 To i
r = batch
If n = i Then
r = lastrow Mod batch
End If
If r > 0 Then
ReDim ar(r - 1)
For j = 1 To r
ar(j - 1) = data(j + n * batch, 1)
Next
' do something
Debug.Print Join(ar, ",")
End If
Next
End Sub
2d array because to lazy to encode 1d but same idea with 1d:
Sub test()
arr = Sheet3.Range("A1").CurrentRegion.Value2
x = UBound(arr)
y = 5
jj = y
For j = 1 To UBound(arr)
sumaction = sumaction + arr(j, 1)
If (UBound(arr) - jj) < 0 Then
jj = UBound(arr)
sumaction = 0
End If
If j = jj Then
dosomething = sumaction * 2
sumaction = 0
jj = jj + y
End If
Next j
End Sub
I'm looking for a more efficient, less hard-coded way of transposing an array and then autofilling formulas in adjacent columns. Here is my current code for transposing my array in a specific spot on the sheet and autofilling the columns:
If Len(Join(myArray)) > 0 Then
ActiveWorkbook.Sheets("Delta Summary").Range("A3:A" & UBound(myArray) + 2) = WorksheetFunction.Transpose(myArray)
ActiveWorkbook.Sheets("Delta Summary").Range("B3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFill Destination:=Range("B3:K17"), Type:=xlFillDefault
Else: End If
The goal is to transpose the array starting in cell A3 on sheet "Delta Summary". My code accomplishes this, but I'm wondering if there's a better way to do it. For reference, I loop through this array and transpose it several times based on different criteria. I transpose the array beginning at cells A3, A20, A37,..., and A224. Each section has 15 cells allocated for data.
As for the auto-fill, I'd like to auto-fill the formulas in columns B:K down to the last populated cell in column A for that pre-defined range (ex. A3:A17, A20:34, etc.). I don't know how to find the last populated cell for a pre-defined range, so I have this hardcoded.
I'm still learning, so any insight would be greatly appreciated!
Edit: Here is one example of the looping criteria I use to populate my array:
ReDim myArray(0)
For i = 1 To LastCurrID
If ActiveWorkbook.Sheets("Weekly Comparison").Range("N" & i) = "N" And ActiveWorkbook.Sheets("Weekly Comparison").Range("J" & i) = "Billing" Then
myArray(UBound(myArray)) = ActiveWorkbook.Sheets("Weekly Comparison").Range("A" & i)
ReDim Preserve myArray(UBound(myArray) + 1)
End If
Next i
Edit #2: For those who are curious, here's the completed code. I only slightly changed what was commented below.
ReDim myArray(0)
For i = 1 To LastCurrID
If wkb.Sheets("Weekly Comparison").Range("N" & i) = "N" And wkb.Sheets("Weekly Comparison").Range("J" & i) = "Billing" Then
myArray(UBound(myArray)) = wkb.Sheets("Weekly Comparison").Range("A" & i)
ReDim Preserve myArray(UBound(myArray) + 1)
End If
Next i
For y = LBound(myArray) To UBound(myArray)
If Len(Join(myArray)) > 0 Then
With wks
.Range("A" & x & ":A" & UBound(myArray) + x - 1) = WorksheetFunction.Transpose(myArray)
Dim lRow As Long
lRow = .Range("A" & x).End(xlDown).Row - x + 1
.Range("B" & x).Resize(1, 10).AutoFill _
Destination:=.Range("B" & x).Resize(lRow, 10), Type:=xlFillDefault
End With
End If
Next
x = x + 17
EDIT (Based on OP Update Question with Looping)
From the way you build your array, it seems like the array is loading with the last row of the data range to be copied (within the 15 row limit) for each range.
The below will loop through the array again, and will set a factor of 17 to x for each loop (starting at 3) and will find the last row within the specified range starting at 'Bx' and uses the .Resize method to do the AutoFill:
'always best to qualify the workbook, worksheet objects with a variable
Dim wkb As Workbook, wks As Worksheet
Set wkb = Workbooks("myWKb")
Set wks = wkb.Sheets("Delta Summary")
Dim x As Long, y As Long
x = 3
For y = LBound(myArray) To UBound(myArray)
If Len(Join(myArray)) > 0 Then
With wks
.Range("A" & x & ":A" & UBound(myArray) + 2) = WorksheetFunction.Transpose(myArray)
Dim lRow As Long
lRow = .Range("A" & x).End(xlDown).Row
.Range("B" & x).Resize(1, 10).AutoFill _
Destination:=.Range("B" & x).Resize(lRow, 10), Type:=xlFillDefault
End With
End If
x = x + 17
Next
Problem:
Nothing is being written into cells in column P. The line Cells(x, "P").Value = failingClasses should do this.
Description: (VBA script below)
I've got a column with ID numbers. There can be multiple rows with each ID number. What I need to do is concatenate all the corresponding values in another column and write this into a cell in the original row. This needs to be done for each row in the sheet.
Field 1 is where the IDs are, field 6 is where the information I want to concatenate is, I'm trying to write the concatenation into column P.
Right now, I think that the computation is being done correctly, but for what ever reason it isn't writing to the cell in P?
Macro takes for ever to run. Between 1k and 2k rows when run.
Thanks!
Worksheets("RAW GRADE DATA").Select
' Turn off auto calc update and screen update -- saves speed
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim x As Long, y As Long, totalGradeEntries As Long, failingClasses As String, failingClassesCell As Excel.Range
totalGradeEntries = Cells(Rows.Count, 1).End(xlUp).Row
For x = totalGradeEntries To 1 Step -1
failingClasses = ""
For y = totalGradeEntries To 1 Step -1
If Cells(y, 1).Value = Cells(x, 1).Value And Cells(x, 6) <> "02HR" Then
failingClasses = failingClasses & " " & Cells(y, 1).Value
End If
Cells(x, "P").Value = failingClasses
Next y
Next x
' Turn calc and screen update back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I got the bones of a solution to this work, thanks to Ron Rosenfeld -- Here is the code, working on a test sheet with 3 columns of data, the Unique IDs being in column 1.
Sub CalcArrary()
'Declare variables
Dim numRows As Integer, calcArray() As Variant
'Set the number of rows in the sheet
numRows = ActiveSheet.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
ReDim calcArray(numRows - 1, 4)
For i = 0 To numRows - 2
calcArray(i, 1) = Range("A" & i + 2)
calcArray(i, 2) = Range("B" & i + 2)
calcArray(i, 3) = Range("C" & i + 2)
Next i
For b = 0 To numRows - 2
For c = 0 To numRows - 2
If calcArray(c, 1) = calcArray(b, 1) And calcArray(c, 3) < 60 Then
calcArray(b, 4) = calcArray(b, 4) & calcArray(c, 2) & ", " & calcArray(c, 3) & "% "
End If
Next c
Next b
For d = 0 To numRows - 2
ActiveSheet.Range("D" & d + 2) = calcArray(d, 4)
Next d
End Sub
I have an array which I transpose (I already have the code for this) see below. I now wish to adapt the code so that the following can take place.
Each item in the array is duplicated so for example
Original Array
1 5
2 7
3 11
4 15
becomes
1 1 2 2 3 3 4 4
5 5 7 7 11 11 15 15
As I mentioned the code I have does the transposing I just cant work out how to duplicate
Public Sub DynamicTranspose1()
Dim I As Variant
Dim J As Variant
Dim transArray() As Variant
Dim numRows As Integer
Dim numColumns As Integer
'—————————————-
'Get rows for dynamic array.
'—————————————-
Do
numRows = I
I = I + 1
Loop Until Cells(I, "A").Value = ""
'———————————————-
'Get columns for dynamic array.
'———————————————-
I = 0
Do
numColumns = I
I = I + 1
Loop Until Cells(1, Chr(I + 64)).Value = ""
ReDim transArray(numRows - 1, numColumns - 1)
'—————————————————-
'Copy data from worksheet to array.
'—————————————————-
For I = 1 To numColumns
For J = 1 To numRows
transArray(J - 1, I - 1) = Cells(J, Chr(I + 64)).Value
Next J
Next I
maxcol = Split(Cells(1, numColumns).Address, "$")(1)
Range("A1:" & maxcol & numRows).ClearContents
'———————————————————————
'Copy data from array to worksheet transposed.
'———————————————————————
For I = 1 To numColumns
For J = 1 To numRows
Cells(I, Chr(J + 64)).Value = transArray(J - 1, I - 1)
Next J
Next I
End Sub
Can someone assist?
Why not just this?
Dim arrIn As Variant
Dim arrOut As Variant
Dim i As Long, j As Long
'Get data from sheet
arrIn = Range("B9:C12").Value 'or wherever your data is located
'Duplicate the data & transpose
ReDim arrOut(1 To UBound(arrIn, 2), 1 To 2 * UBound(arrIn, 1))
For i = 1 To UBound(arrIn, 1)
For j = 1 To UBound(arrIn, 2)
arrOut(j, (2 * i) - 1) = arrIn(i, j)
arrOut(j, 2 * i) = arrIn(i, j)
Next j
Next i
'now slap it back onto the sheet
Range("G17").Resize(UBound(arrIn, 2), 2 * UBound(arrIn, 1)).Value = arrOut
Looping does not take long — unless you are looping through cells to read/write data to/from individual cells in the sheet one at a time. This is what you do, and it will indeed take ages.
In the code above, you will notice that I don't do that. I read the entire array at once, and write it all at once at the end; the .Value property of Range objects will let you do this.
Once the array is read in, looping through it is as quick as it gets.