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.
Related
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 interesting problem. I need to fill in a 2D array with data, but I don't know how many data points there are until after the array is populated.
Dim finalArray(0 to 500000, 0 to 3)
R=0
For Each index in someDictionary
If Not someDictionary.item(index)(1) = 0
finalArray(R,0) = someDictionary.item(index)(1)
finalArray(R,1) = someDictionary.item(index)(2)
finalArray(R,2) = someDictionary.item(index)(3)
R = R + 1
End If
Next index
The issue is that I don't know how many items will be in the dictionary, nor how many will be nonzero. The only way I know is after I run the loop and have a count R.
Currently I'm printing the entire 500k row array to Excel, which is usually 100-400k rows of data with the rest blank. This is ungainly, and I would like to re-dimension the array to be the correct size. I can't use ReDim because I can't delete the data, and I can't use ReDim Preserve because it's 2-dimensional and I need to reduce the rows, not columns.
How about this?
Sub Sample()
Dim finalArray()
Dim R As Long
For Each Index In someDictionary
If Not someDictionary.Item(Index)(1) = 0 Then R = R + 1
Next Index
ReDim finalArray(0 To R, 0 To 3)
R = 0
For Each Index In someDictionary
If Not someDictionary.Item(Index)(1) = 0 Then
finalArray(R, 0) = someDictionary.Item(Index)(1)
finalArray(R, 1) = someDictionary.Item(Index)(2)
finalArray(R, 2) = someDictionary.Item(Index)(3)
R = R + 1
End If
Next Index
End Sub
You have a few options
Redim the array as needed rather then create up front (which I think is better than looping through the array twice :)). I have added this given your comment to tigeravatar
Transpose the array to redim the first dimension
Ignore the redundant data as per tigeravatar
Option 1
note I have flipped the data to make the point around testing for ReDim as you go rather than define an array size up front - it could well argue this changes the nature of the question but I thought the technique worth pointing out. Option2 shows how to transpose the array regardless
Sub SloaneDog()
Dim finalArray()
Dim R As Long
Dim lngCnt As Long
Dim lngCnt2 As Long
lngCnt = 100
ReDim finalArray(1 To 3, 1 To lngCnt)
somedictionary = Range("A1:C3001")
For lngCnt2 = 1 To UBound(somedictionary, 1)
finalArray(1, lngCnt2) = "data " & lngCnt2
If lngCnt2 Mod lngCnt = 0 Then ReDim Preserve finalArray(1 To 3, 1 To lngCnt2 + lngCnt)
Next
End Sub
Option 2
Sub EddieBetts()
Dim X()
Dim Y()
Dim LngCnt As Long
ReDim X(1 To 1000, 1 To 3)
Debug.Print UBound(X, 1)
LngCnt = 100
Y = Application.Transpose(X)
ReDim Preserve Y(1 To UBound(Y, 1), 1 To LngCnt)
X = Application.Transpose(Y)
Debug.Print UBound(X, 1)
End Sub
I create an array in vba by looping through cells in a sheet (originalWS). So let's say cells (2,5) to (2,12) have the following:
(2,5)Item
(3,5)Type
(4,5)Nominal Diameter
(5,5)Lead
.
.
.
(12,5)For Use with End Blocks
Thus, when I loop with the code below I get an array that looks like this:
[Item,Type,Nominal Diameter,Lead,...,For Use with End Blocks].
However, I would like to add two empty spaces between each value in my array. so that it looks like this:
[Item,"","",Type,"","",Nominal Diameter,"","",Lead,"","",...,For Use with End Blocks,"",""]
ReDim propertyArr(1, lastRow)
For i = 1 To lastRow
propertyArr(1, i) = originalWS.Cells(i + 1, 5).Value
Debug.Print propertyArr(1, i)
Next
I have tried to loop to by the final total size of the array so (lastRow*3) and step forward by 3. However, I'm having a hard time figuring out how I would reset my orginalWS.cells(i,5) values so that they are consecutive.
In other words, when I loop stepping by 3 my values would be:
propertyArr(1,1) = originalWS.Cells(2,5).value
propertyArr(1,4) = originalWS.cells(5,5).value
propertyArr(1,7) = originalWS.cells(8,5).value
How can I loop so that I store values in my array every 2 places, while I get the values from a consecutive list in a sheet.
Can I do this without having to add extra empty row
a way to add two empty spaces between each value within my original loop without having to add extra empty rows?
Or, can I add the two empty spaces between each value after I created my array the first time?
This should do the trick,
Dim lRowNo As Long
lRowNo = lastRow * 3
ReDim propertyArr(1, lRowNo)
For i = 1 To lRowNo
If i Mod 3 = 1 Then
propertyArr(1, i) = originalWS.Cells(i + 1, 5).Value
Else
propertyArr(1, i) = ""
End If
Debug.Print propertyArr(1, i)
Next
Something like:
Sub ytrewq()
Dim propertyArr(), lastRow As Long
Dim originalWS As Worksheet
Set originalWS = ActiveSheet
lastRow = 5
ReDim propertyArr(1, 2 * lastRow)
For i = 1 To 2 * lastRow Step 2
propertyArr(1, i) = originalWS.Cells(i + 1, 5).Value
propertyArr(1, i + 1) = ""
Debug.Print propertyArr(1, i)
Next
End Sub
UNTESTED
You can also unroll the loop a bit to do this a bit more efficiently. Note that for each iteration, i isn't incremented by 1, but by 3.
Public Sub test()
Dim lastRow As Long
lastRow = 6
Dim lastIndex As Long
lastIndex = lastRow * 3
ReDim propertyArr(1 To lastIndex)
Dim i As Long
For i = 1 To lastIndex Step 3
propertyArr(i) = CInt(i / 3)
propertyArr(i + 1) = vbNullString
propertyArr(i + 2) = vbNullString
Next
End Sub
Or without loops
Dim ws As Worksheet
Set ws = Sheets(1)
propertyarr = Join(Application.Transpose(ws.Range("E1:E5")), ","""","""",")
to put back into array
propertyarr = Split(Join(Application.Transpose(ws.Range("E1:E5")), ",,,"), ",")
I figured out the answer. I wasn't updating the cells I needed correctly. See code below:
count = 3
lastIndex = lastRow * 3
ReDim propertyArr(1, lastIndex)
For i = 1 To lastIndex Step 3
propertyArr(1, i) = originalWS.Cells((count - 1), 5)
count = count + 1
Next