So, I'm trying to print modified iterations of an array of 100; for the first row I want 1 to 100 of the array, for the second 2 to 100, all the way to the 100th row with just array(100), and all of these rows starting with column A. I can print the first row just fine, but for the subsequent ones I'm not getting any output.
q = 1
For m = 1 To last_age
Sheets("Sheet1").Range(Cells(q, 1), Cells(q, UBound(Data) + 1)) = Data 'Works the first pass, but not for q>1
For p = 0 To UBound(Data) - 1
Data(p) = Data(p + 1)
Next p
If UBound(Data) > 0 Then
ReDim Data(0 To UBound(Data) - 1)
q = q + 1
End If
Next m
All my variables seem to be incrementing correctly, but after the first m loop my Data array isn't being put in the second row. Any thoughts?
Slightly different approach:
Sub Tester()
Dim data(100), i, last_age, sht As Worksheet, q, m
'fill test array
For i = 1 To 100: data(i - 1) = i: Next
Set sht = Sheets("Sheet1")
last_age = 100
q = 1
sht.Cells(q, 1).Resize(1, UBound(data) + 1) = data
For m = 2 To last_age
q = q + 1
sht.Cells(1, 1).Offset(0, m - 1).Resize( _
1, (UBound(data) + 1) - (m - 1)).Copy _
sht.Cells(q, 1)
Next m
End Sub
You are re-dimensioning your array in this line:
ReDim Data(0 To UBound(Data) - 1)
but you are not using the Preserve keyword so your data is getting deleted. Try using:
ReDim Preserve Data(0 To UBound(Data) - 1)
Related
I have a ListBox1 in UserForm1. When I send a multi-row array to a .List, everything works. But when I send only a one-row array, the values in the ListBox1 are arranged one below the other in first column. Independent of use Application.Transpose.
I tried to write a condition and a for loop, but it doesn't work.
Run-time error 381
Could not set the List property. Invalid property array index.
.AddItem cannot be used because there are more than 10 columns
Do you have any other solution?
Dim sumItem As Integer: sumItem = 0 'later between 1 and 5000
.
.
ReDim Preserve arrSort(0 To (columnCount - 1 + 2), 0 To sumItem - 1)
.
.
Call Load(UserForm1) 'to be able to manipulate components
If sumItem = 1 Then 'if only one ROW is loaded in the array
Dim qq As Byte
For qq = 0 To (columnCount - 1)
UserForm1.ListBox1.List(0, qq) = arrSort(qq, 0) 'need to fill the LISTBOX ROW here
Next qq
ElseIf sumItem > 1 Then
UserForm1.ListBox1.List = Application.Transpose(arrSort) 'if more than one ROW is filled, this works
Else
End If
UserForm1.Show
Thank's to #Tim Williams
This work for me:
Dim sumItem As Integer: sumItem = 0 'later between 1 and 5000
.
.
ReDim Preserve arrSort(0 To (columnCount - 1 + 2), 0 To sumItem - 1) 'the dimensions are reversed
.
.
Call Load(UserForm1) 'to be able to manipulate components
If sumItem = 1 Then 'if only one ROW is loaded in the array
Dim qq As Byte
Dim arrTmp(0 To 0, 0 To (columnCount - 1)) As Variant 'auxiliary array for dimension exchange
For qq = 0 To (columnCount - 1)
arrTmp(0, qq) = arrSort(qq, 0)
Next qq
UserForm1.ListBox1.List = arrSort
ElseIf sumItem > 1 Then
UserForm1.ListBox1.List = Application.Transpose(arrSort) 'if more than one ROW is filled, this works
Else
End If
UserForm1.Show
You can do something like this:
Const NUM_COLS As Long = 20
Private Sub UserForm_Activate()
Dim lstInit(0 To 0, 0 To NUM_COLS - 1), r As Long, c As Long
Me.ListBox1.ColumnCount = NUM_COLS
'fill a row of dummy data....
For c = 0 To NUM_COLS - 1
lstInit(0, c) = "R1:C" & (c + 1)
Next c
Me.ListBox1.List = lstInit
End Sub
Private Sub CommandButton1_Click()
Dim arr, c As Long, ub As Long
arr = AddARow(Me.ListBox1.List) 'get the existing listbox data and add a row
ub = UBound(arr, 1)
For c = 0 To UBound(arr, 2)
arr(ub, c) = "R" & (ub + 1) & ":C" & (c + 1) 'populate the added row
Next c
Me.ListBox1.List = arr 'refresh the listbox
End Sub
'add one "row" to a 2D array and return the new array
Function AddARow(lst)
Dim lstNew, r As Long, c As Long
ReDim lstNew(0 To UBound(lst, 1) + 1, 0 To UBound(lst, 2))
'copy existing data
For r = 0 To UBound(lst, 1)
For c = 0 To UBound(lst, 2)
lstNew(r, c) = lst(r, c)
Next c
Next r
AddARow = lstNew
End Function
I have a 2-dimensional range (i, j) like this:
1 2 3 4 5
6 7 8 9 0
I want to copy&paste it to another sheet like this:
1 6 2 7 3 8 4 9 5 0
I need to recalculate the 2-dim range many times and store the results on another sheet, where each row stores one iteration.
Right now I store all calculations in a array (N, i*j) using two for-loops and then paste all itearations on another sheet.
Is there a faster way to do that?
Current code:
Dim a(1 To 100, 1 To 10) As Double
For iter = 1 To 100
Calculate
For i = 1 To 2
For j = 1 To 5
a(iter, i + j * (i - 1)) = Cells(i, j)
Next j
Next i
Next iter
With Sheets("results")
Range(.Cells(1, 1), .Cells(100, 2 * 5)) = a
End With
UPD:
After each "calculate" the values of the initial range change. The example just illustrates how the values from 2-d range should be stored in one row.
UPD2:
Corrected my current code
Something like this should work for you:
Sub tgr()
Dim rData As Range
Dim iter As Long
Dim lNumIterations As Long
Dim i As Long, j As Long, k As Long
Dim a() As Double
Dim aAfterCalc As Variant
Set rData = Sheets("Data").Range("A1:E2")
lNumIterations = 100
ReDim a(1 To lNumIterations, 1 To rData.Rows.Count * rData.Columns.Count)
For iter = 1 To lNumIterations
k = 0
Calculate
aAfterCalc = rData.Value
For j = 1 To rData.Columns.Count
For i = 1 To rData.Rows.Count
k = k + 1
a(iter, k) = aAfterCalc(i, j)
Next i
Next j
Next iter
Sheets("results").Range("A1").Resize(lNumIterations, UBound(a, 2)).Value = a
End Sub
Try this. It gives your desired output and only uses two loops (instead of three)
' For loop
Dim i As Long, j As Long
' Initalise array
Dim tmp(1 To 100, 1 To 10) As Variant
'Loop through all rows in already initalised array
For i = LBound(tmp, 1) To UBound(tmp, 1)
'Calculate to get updated row contents
Calculate
'Loop through each column in row
'The Round and divided by two is to calculate the number of columns concerned instead of the number in the array
For j = LBound(tmp, 2) To Round((UBound(tmp, 2) + 0.1) / 2)
'First row
tmp(i, (j + j - 1)) = Cells(1, j).Value2
'Second row
' If incase the array is initalised to an odd number otherwise this would be out of range
If j * 2 <= UBound(tmp, 2) Then
tmp(i, j * 2) = Cells(2, j).Value2
End If
Next j
Next i
' Write back to sheet
With Sheets("results").Cells(1, 1)
Range(.Offset(0, 0), .Offset(UBound(tmp, 1) - 1, UBound(tmp, 2) - 1)) = tmp
End With
Not sure I get you, but something like this
Sub test()
Dim a() As Variant
Dim b() As Variant
a = Range("a1:e1").Value
b = Range("a2:e2").Value
For x = 1 To 5
Range("H1").Offset(0, x).Value = a(1, x)
Range("H1").Offset(0, 5 + x).Value = b(1, x)
Next x
End Sub
Private Sub this()
Dim this As Variant, counter As Long, that As Integer, arr() As Variant
counter = 0
this = ThisWorkbook.Sheets("Sheet3").UsedRange
For i = LBound(this, 2) To UBound(this, 2)
counter = counter + 2
ReDim Preserve arr(1 To 1, 1 To counter)
arr(1, counter - 1) = this(1, i)
arr(1, counter) = this(2, i)
Next i
ThisWorkbook.Sheets("Sheet4").Range(ThisWorkbook.Sheets("Sheet4").Cells(1, 1), ThisWorkbook.Sheets("Sheet4").Cells(1, counter)).Value2 = arr
End Sub
I have a array which have 1 or more columns and now I want to add one more column (consists only of 1), but I don't know how do do that. The situation looks like that:
My code:
Dim X() As Variant
X = Range("A1:C3").Value2
It's is important to put column with 1 as first. Probably I need to use ReDim Preserve but nothing works for me.
I think you have some options, but instead of extending the index of the array and transposing, trying to move the values etc which seems too much of a hassle, I would rather add 1 to the Excel range and then create the array:
Range("B1:D3").Value2 = Range("A1:C3").Value2
Range("A1:A3").Value2 = 1
X = Range("A1:D3").Value2
Resize the Array adding a column to the last dimension
Shift all the data to the right.
Assign 1 to the first position in each row
Sub AddColumnShiftData()
Dim X As Variant
Dim i As Long, j As Long
X = Range("A1:C3").Value2
ReDim Preserve X(1 To 3, 1 To 4)
For i = 1 To UBound(X)
For j = UBound(X, 2) To 2 Step -1
X(i, j) = X(i, j - 1)
Next
X(i, 1) = 1
Next
End Sub
Try matrix multiplication by the identify matrix....Well almost identity matrix. Then add 1 to every element in of the resulting matrix. You can use the Excel's Worksheet function for matrix multiplication.
Almost identity matrix
Dim X As Variant
X = Range("A1:C3").Value2
Dim Y As Variant
n = UBound(X, 2)
m = n + 1
Z = UBound(X, 1)
ReDim Y(1 To n, 1 To m)
'Set All values to zero
For i = 1 To n
For j = 1 To m
Y(i, j) = 0
Next j
Next i
' Set offset diagonal to 1
For i = 1 To n
Y(i, i + 1) = 1
Next i
' Matrix MMult
X = Application.WorksheetFunction.MMult(X, Y)
' Add 1 to the first column
For i = 1 To Z
X(i, 1) = 1
Next i
Alternative via Application.Index()
Just for fun (note that the resulting array is a 1-based 2-dim array):
Sub AddFirstIndexColumn()
Const FIXEDVALUE = 1 ' value to replace in new column 1
'[1] get data
Dim v: v = getExampleData()
'[2] define column array inserting first column (0 or 1) and preserving old values (1,2,3)
v = Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v) & ")"), _
Array(1, 1, 2, 3)) ' columns array where 0 reinserts the first column
' [3] add an current number in the first column
Dim i As Long
For i = LBound(v) To UBound(v): v(i, 1) = FIXEDVALUE: Next i
End Sub
Function getExampleData()
' Method: just for fun a rather unusual way to create a 2-dim array
' Caveat: time-consuming for greater data sets; better to assign a range to a datafield array
Dim v
v = Array(Array(2, 3, 5), Array(3, 8, 9), Array(4, 2, 1))
v = Application.Index(v, 0, 0)
getExampleData = v
End Function
Related links
Some pecularities of `Application.Index()
Insert vertical slices into array
I have the below snippit for excel 2013 VBA
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
ReDim Preserve testArr(1 To FNum, 1 To 23)
testArr(FNum) = r
End If
Next r
My goal is to get all the visible rows from a filtered table into an array.
The table can be any number of rows, but always 23 columns.
I found that the height will be zero if it is hidden. But for the life of me, I cannot figure out how to get the entire row into the array.
r = listrow
rr = listrows
YES, I know a looping redim sucks.
SpecialCells(xlCellTypeVisible)
doesnt work either because it stops at the first hidden row/column.
I may just dump the entire table into the array and then filter the array. I havent figured out how to pull the active filter from the table to apply it, but I havent looked deeply into that yet. Thats what I will be doing now, because I am stuck for the other way.
Any and all advice is welcome.
DM
To avoid REDIM or double loops you can use something like Application.WorksheetFunction.Subtotal(3, Range("A2:A500000")) to quickly count the number of visible rows.
See this question
I define my Target range using .SpecialCells(xlCellTypeVisible). Target.Cells.Count / Target.Columns.Count will give you the row count. Finally I iterate over the cells in the Target range incrementing my counters based off of the Target.Columns.Count.
Public Sub FilteredArray()
Dim Data As Variant, r As Range, Target As Range
Dim rowCount As Long, x As Long, y As Long
Set Target = WorkSheets("Sheet1").ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible)
If Not Target Is Nothing Then
rowCount = Target.Cells.Count / Target.Columns.Count
ReDim Data(1 To rowCount, 1 To Target.Columns.Count)
x = 1
For Each r In Target
y = y + 1
If y > Target.Columns.Count Then
x = x + 1
y = 1
End If
Data(x, y) = r.Value
Next
End If
End Sub
The code below will create an array for all the rows and store each of these into another array that will store all info in sheet:
Function RowsToArray()
Dim lastRow: lastRow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastCol: lastCol = ActiveWorkbook.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim newArr()
ReDim newArr(lastRow)
For r = 0 To lastRow - 1
Dim rowarr()
ReDim rowarr(lastCol)
For c = 0 To lastCol - 1
rowarr(c) = Cells(r + 1, c + 1).Value
Next c
newArr(r) = rowarr
Next r
End Function
Can you loop over the cells in rr rather than the rows? If so, as #SJR says, you can only Redim Preserve the final dimension, so we're going to have to switch your dimensions. You can then use r.EntireRow.Hidden to check if we're in a visible row and increase the bound of your array by one if we are.
The following assumes that your data starts in column A:
For Each r In rr
If Not r.EntireRow.Hidden Then
If r.Column = 1 Then
If UBound(testArr, 2) = 0 Then
ReDim testArr(1 To 23, 1 To 1)
Else
ReDim Preserve testArr(1 To 23, 1 To UBound(testArr, 2) + 1)
End If
End If
testArr(r.Column, UBound(testArr, 2)) = r
End If
Next r
Edit:
Alternatively, you can keep using ListRows, but loop through twice, once to set the bounds of your array, and once to fill the array (which will have its own internal loop to run through the row...):
For Each r In rr
If Not r.Range.Height = 0 Then
Fnum = Fnum + 1
ReDim testArr(1 To Fnum, 1 To 3)
End If
Next r
Fnum = 0
For Each r In rr
If Not r.Range.RowHeight = 0 Then
Fnum = Fnum + 1
dumarray = r.Range
For i = 1 To 3
testArr(Fnum, i) = dumarray(1, i)
Next i
End If
Next r
Thanks all, a combo of answers led me to: (not very elegant, but quick)
For Each r In rr
If Not r.Range.Height = 0 Then
TNum = TNum + 1
End If
Next r
ReDim testArr(TNum, 23)
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
For i = 1 To 23
testArr(FNum, i) = r.Range.Cells(, i)
Next i
End If
Next r
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.