Dim i As Integer, q As Integer
Dim rng As Range
Dim my_array1elm
Dim my_array2elm
Dim x As Long
Sub Yoo()
Range("B1").Select
For i = 1 To 12
ActiveCell.Value = i
ActiveCell.Offset(0, 1).Select
Next
Range("A2").Select
For q = 1 To 12
ActiveCell.Value = q
ActiveCell.Offset(1, 0).Select
Next
my_array1 = Range("B1:M1").Select
my_array2 = Range("A2:A13").Select
my_array3 = Range("B2:M13").Select
Now I would like to multiply each elements in my_array1 with each elements in my_array2. Then populate the result(matrix) to my_array3
Having trouble to figure out looping.
Reading and writing to/from the worksheet is inefficient. Better to do your multiplying within VBA arrays, and then writing the arrays to the worksheet.
Note that the horizontal array is one-dimension, the vertical and multi-column arrays are 2D.
For example:
Option Explicit
Dim i As Integer, q As Integer
Dim rng As Range
Dim my_array1
Dim my_array2
Dim my_array3
Sub Yoo()
ReDim my_array1(1 To 12) 'horizontal array
ReDim my_array2(1 To 12, 1 To 1) 'vertical array
For i = 1 To 12
my_array1(i) = i
my_array2(i, 1) = i
Next i
ReDim my_array3(1 To 12, 1 To 12) 'results array
For i = 1 To 12
For q = 1 To 12
my_array3(i, q) = my_array1(i) * my_array2(q, 1)
Next q
Next i
Cells.Clear
Range("B1:M1") = my_array1
Range("A2:A13") = my_array2
Range("B2:M13") = my_array3
End Sub
sticking to Excel members you could use
Sub Yoo()
Range("B1").Resize(, 12).Formula = "=COLUMN()-1"
Range("A2").Resize(12).Formula = "=ROW()-1"
Range("B2").Resize(12, 12).FormulaR1C1 = "=RC1*R1C"
With Range("A1").Resize(13, 13)
.Value = .Value
End With
End Sub
Array Multiplication Table
Change the values in the Constants section as you see fit.
The Code
Sub ArrayMultiplicationTable()
Const cTarget As String = "A1" ' Target First Cell Range
Const cCol As Long = 12 ' Size of Column Source Range
Const cRow As Long = 12 ' Size of Row Source Range
Dim vntCol As Variant ' Column Source Array
Dim vntRow As Variant ' Row Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Row Array and Target Array Row Counter
Dim j As Long ' Column Array and Target Array Column Counter
' Redim Source Arrays
ReDim vntCol(1 To cCol, 1 To 1)
ReDim vntRow(1 To 1, 1 To cRow)
' Populate Column Source Array.
For i = 1 To cCol
vntCol(i, 1) = i
Next
' Populate Row Source Array.
For j = 1 To cRow
vntRow(1, j) = j
Next
' Redim Target Array.
ReDim vntT(1 To cCol, 1 To cRow)
' Loop through rows of Column Source Array.
For i = 1 To UBound(vntCol)
' Loop through columns of Row Source Array.
For j = 1 To UBound(vntRow, 2)
' Write to Target Array.
'vntT(i, j) = vntCol(i, 1) * vntRow(1, j)
' The following is a simplification of the previous line since
' numbers from 1 to Size of Row or Column Source Range are used
' as the values in the Source Arrays.
vntT(i, j) = i * j
Next
Next
' Copy Arrays to Ranges.
Range(cTarget).Offset(, 1).Resize(, cRow) = vntRow
Range(cTarget).Offset(1).Resize(cCol) = vntCol
Range(cTarget).Offset(1, 1).Resize(cCol, cRow) = vntT
End Sub
mmult result calculated by vba:
Option Explicit
Sub MatrixMultiplication()
Dim myArr1 As Variant
Dim myArr2 As Variant
Dim result As Variant
myArr1 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)
myArr2 = Application.WorksheetFunction.Transpose(myArr1)
Range("A2:A21") = myArr2
Range("B1:U1") = myArr1
result = Application.MMult(myArr2, myArr1)
Range("B2:U21") = result
'Range("B2:U21").FormulaArray = "=MMULT(A2:A21;B1:U1)"
'Range("B2:U21").FormulaArray = "=MMULT(RC[-1]:R[19]C[-1],R[-1]C:R[-1]C[19])"
End Sub
UPDATED:
Recorded matrix multiplication with worksheet function MMULT:
Sub RecordedMatrixMultiplication()
'
' RecordedMatrixMultiplication Macro
' selects manually removed, as proposed by Ron Rosenfeld
'
Range("A2").Value = 1
Range("A3").Value = 2
Range("A2:A3").AutoFill Destination:=Range("A2:A21"), Type:=xlFillDefault
Range("A2:A21").Copy
Range("B1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:= False, Transpose:=True
Application.CutCopyMode = False
Range("B2").FormulaR1C1 = "=MMULT(RC[-1]:R[19]C[-1],R[-1]C:R[-1]C[19])"
Range("B2:U21").FormulaArray = "=MMULT(RC[-1]:R[19]C[-1],R[-1]C:R[-1]C[19])"
End Sub
Related
There are some questions about splitting arrays but in my case something goes wrong when I want to output the arrays onto the Worksheet. Also, my solution seems a bit complicated.
My goal is to split a 1-dimensional array with 2.5 mln elements in 4 parts to be able to easily output it to a Worksheet (625,000 rows, 4 columns).
SomeSub() is where the data originates, in this case "i Mod 99" generates some "random" numbers to see some output on the Worksheet. SomeSub() calls the sub SplitArray() which is very the splitting happens. I only have data in a 1-dimensional array but I thought I need to use a 2-dimensional one so that I can get the values from columns into rows by transposing them. Not sure this is actually needed but it works to some degree.
Sub SomeSub()
Dim i As Long
Dim bigarr(1, 2500000) As Integer
Dim timing As Single
timing = Timer
For i = 1 To 2500000
bigarr(1, i) = i Mod 99
Next i
Call SplitArray(bigarr)
Debug.Print Format(Timer - timing, "0.0") & " seconds"
End Sub
Sub SplitArray(ByRef arr0() As Integer)
Dim i As Long
Dim arr1(1, 625000) As Integer
Dim arr2(1, 625000) As Integer
Dim arr3(1, 625000) As Integer
Dim arr4(1, 625000) As Integer
For i = 1 To 625000: arr1(1, i) = arr0(1, i): Next i
For i = 625001 To 1250000: arr2(1, i - 625000) = arr0(1, i): Next i
For i = 1250001 To 1875000: arr3(1, i - 1250000) = arr0(1, i): Next i
For i = 1875001 To 2500000: arr4(1, i - 1875000) = arr0(1, i): Next i
Dim vektor As Variant
Worksheets("Output").Select
vektor = Application.WorksheetFunction.Transpose(arr1)
Range(Cells(11, 1), Cells(625010, 1)).Value = vektor
vektor = Application.WorksheetFunction.Transpose(arr2)
Range(Cells(11, 2), Cells(625010, 2)).Value = vektor
vektor = Application.WorksheetFunction.Transpose(arr3)
Range(Cells(11, 3), Cells(625010, 3)).Value = vektor
vektor = Application.WorksheetFunction.Transpose(arr4)
Range(Cells(11, 4), Cells(625010, 4)).Value = vektor
End Sub
The problem is that my approach works only until row 35186 but not until row 625,010.
Currently the whole procedure takes about 1.9 seconds using 1 thread. This is usually fast enough but a quicker or simpler solution to splitting a "long array" would also be appreciated.
Change your arrays to be vertical instead of horizontal and you can avoid Application.Transpose which has a limit to the number of items it allows:
Sub SplitArray(ByRef arr0() As Integer)
Dim i As Long
Dim arr1(625000, 1) As Integer
Dim arr2(625000, 1) As Integer
Dim arr3(625000, 1) As Integer
Dim arr4(625000, 1) As Integer
For i = 1 To 625000: arr1(i, 1) = arr0(1, i): Next i
For i = 625001 To 1250000: arr2(i - 625000, 1) = arr0(1, i): Next i
For i = 1250001 To 1875000: arr3(i - 1250000, 1) = arr0(1, i): Next i
For i = 1875001 To 2500000: arr4(i - 1875000, 1) = arr0(1, i): Next i
With Worksheets("Output")
.Range(.Cells(11, 1), .Cells(625010, 1)).Value = arr1
.Range(.Cells(11, 2), .Cells(625010, 2)).Value = arr2
.Range(.Cells(11, 3), .Cells(625010, 3)).Value = arr3
.Range(.Cells(11, 4), .Cells(625010, 4)).Value = arr4
End With
End Sub
But you really only need one output array with 4 columns:
Sub SplitArray(ByRef arr0() As Integer)
Dim i As Long
Dim arr1(625000, 4) As Integer
For i = 1 To 625000: arr1(i, 1) = arr0(1, i): Next i
For i = 625001 To 1250000: arr1(i - 625000, 2) = arr0(1, i): Next i
For i = 1250001 To 1875000: arr1(i - 1250000, 3) = arr0(1, i): Next i
For i = 1875001 To 2500000: arr1(i - 1875000, 4) = arr0(1, i): Next i
With Worksheets("Output")
.Range(.Cells(11, 1), .Cells(625010, 4)).Value = arr1
End With
End Sub
Split a 1D Array
Simple
The GetSplitOneD function will return the columns in a 2D one-based array whose values can easily be written (copied) to a range e.g.:
rg.Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
Sub GetSplitOneDtest()
Dim Timing As Double: Timing = Timer
Const nCount As Long = 2500000
Const ColumnsCount As Long = 4
Const dName As String = "Output"
Const dFirstCellAddress As String = "A2"
' Reference the workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim n As Long
' Create the source (sample) array i.e. return the numbers
' from 1 to 'nCount' in a 1D one-based array.
Dim sArr() As Variant: ReDim sArr(1 To nCount)
For n = 1 To nCount
sArr(n) = n
Next n
' Using the 'GetSplitOneD' function, return the split values
' from the source array in the destination array ('dData'),
' a 2D one-based array.
Dim dData() As Variant: dData = GetSplitOneD(sArr, ColumnsCount)
' Write the destination rows count to a variable ('drCount').
Dim drCount As Long: drCount = UBound(dData, 1)
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Reference the destination first cell ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
' Calculate the destination clear rows count ('dcrCount'),
' the number of rows to be cleared below the destination ranges.
Dim dcrCount As Long: dcrCount = dws.Rows.Count - dfCell.Row - drCount + 1
' Write the values from the destination array to the destination ranges.
With dfCell.Resize(, ColumnsCount) ' reference the first row
.Resize(drCount).Value = dData ' write
.Resize(dcrCount).Offset(drCount).Clear ' clear below
End With
Debug.Print Format(Timer - Timing, "0.000") & " seconds"
' Inform.
MsgBox "Data split.", vbInformation
End Sub
Function GetSplitOneD( _
SourceOneD() As Variant, _
ByVal ColumnsCount As Long) _
As Variant()
Dim sCount As Long: sCount = UBound(SourceOneD) - LBound(SourceOneD) + 1
Dim drCounts() As Long: ReDim drCounts(1 To ColumnsCount)
Dim drCount As Long: drCount = Int(sCount / ColumnsCount)
Dim Remainder As Long: Remainder = sCount Mod ColumnsCount
If Remainder > 0 Then
drCount = drCount + 1
drCounts(ColumnsCount) = drCount - ColumnsCount + Remainder
Else
drCounts(ColumnsCount) = drCount
End If
Dim c As Long
For c = 1 To ColumnsCount - 1: drCounts(c) = drCount: Next c
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
Dim s As Long: s = LBound(SourceOneD)
Dim dr As Long
For c = 1 To ColumnsCount
For dr = 1 To drCounts(c)
dData(dr, c) = SourceOneD(s)
s = s + 1
Next dr
Next c
GetSplitOneD = dData
End Function
More Flexible
The GetJaggedSplitOneD function will return the columns in a jagged array containing as many 2D one-based one-column arrays as there are columns. Then you could write each column to another place instead of writing them next to each other. In the test sub, you could change the value of the dcGap constant determining how many empty columns should be in-between. If you don't need this additional functionality, use the first function since it's a little bit faster.
Sub GetJaggedSplitOneDtest()
Dim Timing As Double: Timing = Timer
' Define constants.
Const nCount As Long = 2500000
Const ColumnsCount As Long = 4
Const dName As String = "Output"
Const dFirstCellAddress As String = "A2"
Const dcGap As Long = 2 ' empty columns in-between
' Reference the workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim n As Long
' Create the source (sample) array i.e. return the numbers
' from 1 to 'nCount' in a 1D one-based array.
Dim sArr() As Variant: ReDim sArr(1 To nCount)
For n = 1 To nCount
sArr(n) = n
Next n
' Using the 'GetJaggedSplitOneD' function, return the split values
' from the source array in the destination array ('dJAG'), a jagged array
' containing 4 ('ColumnsCount') same-sized 2D one-based one-column arrays.
Dim dJag() As Variant: dJag = GetJaggedSplitOneD(sArr, ColumnsCount)
' Write the destination rows count to a variable ('drCount').
Dim drCount As Long: drCount = UBound(dJag(1), 1)
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Reference the destination first cell ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
' Calculate the destination clear rows count ('dcrCount'),
' the number of rows to be cleared below the destination ranges.
Dim dcrCount As Long: dcrCount = dws.Rows.Count - dfCell.Row - drCount + 1
' Write the values from the destination array to the destination ranges.
For n = 1 To ColumnsCount
With dfCell
.Resize(drCount).Value = dJag(n) ' write
.Resize(dcrCount).Offset(drCount).Clear ' clear below
End With
Set dfCell = dfCell.Offset(, dcGap + 1)
Next n
Debug.Print Format(Timer - Timing, "0.000") & " seconds"
' Inform.
MsgBox "Data split.", vbInformation
End Sub
Function GetJaggedSplitOneD( _
SourceOneD() As Variant, _
ByVal ColumnsCount As Long) _
As Variant()
Dim sCount As Long: sCount = UBound(SourceOneD) - LBound(SourceOneD) + 1
Dim drCounts() As Long: ReDim drCounts(1 To ColumnsCount)
Dim drCount As Long: drCount = Int(sCount / ColumnsCount)
Dim Remainder As Long: Remainder = sCount Mod ColumnsCount
If Remainder > 0 Then
drCount = drCount + 1
drCounts(ColumnsCount) = drCount - ColumnsCount + Remainder
Else
drCounts(ColumnsCount) = drCount
End If
Dim c As Long
For c = 1 To ColumnsCount - 1: drCounts(c) = drCount: Next c
Dim dJag() As Variant: ReDim dJag(1 To ColumnsCount)
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To 1)
Dim s As Long: s = LBound(SourceOneD)
Dim dr As Long
For c = 1 To ColumnsCount
dJag(c) = dData
For dr = 1 To drCounts(c)
dJag(c)(dr, 1) = SourceOneD(s)
s = s + 1
Next dr
Next c
GetJaggedSplitOneD = dJag
End Function
In the below VBA subroutine I generate an array ("ArrSim") of random numbers, such array measuring 10 rows x 3 columns. This array is pasted into cells A1:C10 of the active worksheet when running the sub. I then generate another array ("ArrRowAvg") where an average is calculated for each row of the ArrSim array. This works fine. The results of this 2nd array, ArrRowAvg, is pasted horizontally into the worksheet in cells E1:N1.
How do I change the code so that ArrRowAvg is instead pasted vertically, always two columns to the right of the ArrSim array? The below code is abbreviated & some of the input variables hard-coded for sake of simplicity; in the full code the user inputs the desired size of ArrSim. I just need to know how to make ArrRowAvg paste vertically. I´ve fiddled with the transpose and index functions with no luck.
Sub Testing()
' Clear contents of active worksheet and move cursor to Cell A1
Cells.Clear
Range("A1").Select
' Declarations of variables and arrays
Dim i As Long, j As Integer
Dim ArrSim() As Double
Dim OutputSim As Range
' Redimension array
ReDim ArrSim(1 To 10, 1 To 3)
' Set worksheet range
Set OutputSim = ActiveCell.Range(Cells(1, 1), Cells(10, 3))
' Fill ArrSim with random values
For i = 1 To 10
For j = 1 To 3
ArrSim(i, j) = Application.RandBetween(0, 100)
Next j
Next i
' Transfer ArrSim to Worksheet
OutputSim.Value = ArrSim
' Generate 1-dimensional array to store the row averages
Dim ArrRowAvg, ArrRow
ReDim ArrRowAvg(10 - 1)
' Loop to calculate row averages from above ArrSim and feed into new array
For i = 0 To UBound(ArrSim, 1) - 1
ArrRow = Application.Index(ArrSim, i + 1, 0)
ArrRowAvg(i) = WorksheetFunction.Average(ArrRow)
Next i
' Paste the array ArrRowAvg values starting one column to the right of OutputSim
OutputSim.Offset(0, 1 + OutputSim.Columns.Count).Resize(1, UBound(ArrRowAvg) + 1).Value = ArrRowAvg
End Sub
Please, use this code line:
OutputSim.Offset(0, 1 + OutputSim.Columns.count).Resize(UBound(ArrRowAvg) + 1, 1).Value = Application.Transpose(ArrRowAvg)
instead of:
OutputSim.Offset(0, 1 + OutputSim.Columns.Count).Resize(1, UBound(ArrRowAvg) + 1).Value = ArrRowAvg
2D One-Column One-Based Array(s)
A Quick Fix
Option Explicit
Sub Testing()
Const FirstCell As String = "A1"
Const rCount As Long = 10
Const cCount As Long = 3
' Clear contents of active worksheet and move cursor to Cell A1
Cells.Clear
Dim cel As Range: Set cel = Range(FirstCell)
cel.Select
' Declarations of variables and arrays
Dim i As Long, j As Long
Dim ArrSim() As Long
Dim OutputSim As Range
' Redimension array
ReDim ArrSim(1 To rCount, 1 To cCount)
' Fill ArrSim with random values
For i = 1 To rCount
For j = 1 To cCount
ArrSim(i, j) = Application.RandBetween(0, 100)
Next j
Next i
' Set worksheet range
Set OutputSim = cel.Resize(rCount, cCount)
' Transfer ArrSim to Worksheet
OutputSim.Value = ArrSim
' Generate 2-dimensional array to store the row averages
Dim ArrRowAvg() As Double
Dim ArrRow As Variant
ReDim ArrRowAvg(1 To rCount, 1 To 1)
' Loop to calculate row averages from above ArrSim and feed into new array
For i = 1 To rCount
ArrRow = Application.Index(ArrSim, i, 0)
ArrRowAvg(i, 1) = Application.Average(ArrRow)
Next i
' Paste the array ArrRowAvg values starting one column to the right of OutputSim
OutputSim.Columns(1).Offset(, cCount).Value = ArrRowAvg
End Sub
My Choice
Sub myChoice()
' Constants
Const FirstCell As String = "A1"
Const rCount As Long = 10
Const cCount As Long = 3
' Arrays
Dim tcCount As Long: tcCount = cCount + 1
Dim Data() As Double: ReDim Data(1 To rCount, 1 To tcCount)
Dim DataRow As Variant
Dim i As Long, j As Long
For i = 1 To rCount
For j = 1 To cCount
Data(i, j) = Application.RandBetween(0, 100)
Next j
DataRow = Application.Index(Data, i, 0)
Data(i, tcCount) = Application.Sum(DataRow) / cCount
Next I
' Worksheet
Application.ScreenUpdating = False
Cells.Clear
With Range(FirstCell)
.Select
.Resize(rCount, tcCount).Value = Data
End With
Application.ScreenUpdating = True
End Sub
I cannot get to work condition for matching 2D arrays. I have tried another approach and this one is closer to the solution, but still does not produce the outcome.
This is what I want to do:
In sheet1 I have different dates that go through columns and size is uncertain. Below these dates are the values:
In sheet 2, I have a smaller subset of dates (that should exist in sheet1):
Through the code, I want to match the dates in sheet1 and sheet2, and only if match is true, I want to write the corresponding values from sheet1 to sheet2.
This is the outcome:
I want to use Arrays for dates in sheet1 and sheet2 and if they match, write the array of values. But the arrays of dates turn to be empty and so condtion for match does not work. I am not getting any error message as well:
Sub test()
Dim arrAmounts() As Variant
Dim arrDates_w2() As Variant
Dim arrDates_w1() As Variant
Dim Lastcol_w2 As Integer
Dim Lastcol_w1 As Integer
Dim LastRow As Integer
Dim i As Integer
Dim w As Integer
Dim d As Integer
Dim f As Integer
Dim g As Integer
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
LastRow = 17 'last row on both sheets
f = 1
g = 1
With w2
Lastcol_w2 = .Cells(3, Columns.Count).End(xlToLeft).Column
'array of dates in w2
ReDim arrDates_w2(1, Lastcol_w2)
End With
With w1
Lastcol_w1 = .Cells(3, Columns.Count).End(xlToLeft).Column
'Assign arrays:
ReDim arrAmounts(LastRow, Lastcol_w1)
ReDim arrDates_w1(1, Lastcol_w1)
For i = 1 To LastRow
For d = 1 To UBound(arrDates_w1, 2)
arrAmounts(i, d) = .Cells(3 + i, 2 + d)
Next
Next
'Match the dates in worksheets 1 and 2
For i = 1 To LastRow
For w = 1 To UBound(arrDates_w2, 2)
For d = 1 To UBound(arrDates_w1, 2)
If arrDates_w2(1, w) = arrDates_w1(1, d) Then
w2.Cells(i + 3, 2 + w) = arrAmounts(i, f + 3)
End If
Next
Next
Next
End With
End Sub
I would appreciate suggestions.
Please try this code.
Option Explicit
Sub CopyColumns()
Const CaptionRow As Long = 3 ' on all sheets
Const FirstClm As Long = 3 ' on all sheets
Dim WsIn As Worksheet ' Input sheet
Dim WsOut As Worksheet ' Output sheet
Dim DateRange As Range ' dates on WsIn
Dim Cin As Long ' input column
Dim Rl As Long ' last row in WsIn
Dim Cl As Long ' last used column in WsOut
Dim C As Long ' column counter in WsOut
Dim Arr As Variant ' transfer values
Set WsIn = Worksheets("Sheet1")
Set WsOut = Worksheets("Sheet2")
With WsIn
Set DateRange = .Range(.Cells(CaptionRow, FirstClm), .Cells(CaptionRow, .Columns.Count).End(xlToLeft))
End With
With WsOut
Cl = .Cells(CaptionRow, .Columns.Count).End(xlToLeft).Column
For C = FirstClm To Cl
On Error Resume Next
Cin = Application.Match(.Cells(CaptionRow, C).Value2, DateRange, 0)
If Err = 0 Then
Cin = Cin + DateRange.Column - 1
Rl = WsIn.Cells(WsIn.Rows.Count, Cin).End(xlUp).Row
Arr = WsIn.Range(WsIn.Cells(CaptionRow + 1, Cin), WsIn.Cells(Rl, Cin)).Value
.Cells(CaptionRow + 1, C).Resize(UBound(Arr)).Value = Arr
End If
Next C
End With
End Sub
What do you expect ReDim arrDates_w2(1, Lastcol_w2) to be doing? As it stands, it's only re-sizing the number of items that can be held in the array... You need to assign the Range to it: arrDates_w2 = w2.Range("C3:K3").Value for example. This will create a multi-dimensional array.
Then you can loop the items. Here's some sample code to illustrate the principle
Sub GetArrayInfo()
Dim a As Variant, i As Long, j As Long
Dim w2 As Worksheet
Set w2 = Sheets("Sheet2")
a = ws.Range("C3:K3").Value2
Debug.Print UBound(a, 1), UBound(a, 2)
For j = 1 To UBound(a, 2)
For i = 1 To UBound(a, 1)
Debug.Print a(i, j)
Next
Next
End Sub
Try
Sub test()
Dim Ws As Worksheet, Ws2 As Worksheet
Dim c As Integer, j As Integer, p As Integer
Dim i As Long, r As Long
Dim arr1() As Variant, arr2() As Variant
Dim rngDB As Range, rngHead As Range
Set Ws = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")
With Ws
c = .Cells(3, Columns.Count).End(xlToLeft).Column
r = .Range("c" & Rows.Count).End(xlUp).Row
Set rngHead = .Range("c3", .Cells(3, c))
arr1 = .Range("c3", .Cells(r, c))
End With
With Ws2
c = .Cells(3, Columns.Count).End(xlToLeft).Column
Set rngDB = .Range("c3", .Cells(r, c))
arr2 = rngDB
End With
For j = 1 To UBound(arr2, 2)
p = WorksheetFunction.Match(arr2(1, j), rngHead, 0)
For i = 2 To UBound(arr2, 1)
arr2(i, j) = arr1(i, p)
Next i
Next j
rngDB = arr2
End Sub
I am currently trying to combine 46 arrays in to a single array. I have scoured the internet, to no prevail and am hoping someone here can help. I did find the below page, but I need to be able to look through each element of the new array in a nested for loop, so using the method below doesn't quite get me to my end goal.
Excel vba - combine multiple arrays into one
Basically, I need to combine my set of 46 arrays in such a way that I can then loop through each element using a nested for loop. ie.
Set of arrays:
myArray1 = (1, 2, 3, 4)
myArray2 = (5, 6, 7)
myArray3 = (8, 9)
myArray4 = (10, 11, 12, 13, 14)
.
.
.
myArray46 = (101, 102, 103)
Combine them to form new array:
myNewArray = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14... 101, 102, 103)
Loop through in nested for loop to check each element against my main array:
For i = LBound(mainArray) to UBound(mainArray)
For j = LBound(myArray) to UBound(myArray)
If mainArray(i) = myArray(j) Then
'do something
End If
Next j
Next i
Any help and/ or guidance with this is greatly appreciated!
Since you write in your comments that your end goal is to create an array of unique elements, you might be best served using a dictionary, where you can test for uniqueness as you add each element to dictionary. Something like:
Option Explicit
Function uniqueArr(ParamArray myArr() As Variant) As Variant()
Dim dict As Object
Dim V As Variant, W As Variant
Dim I As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each V In myArr 'loop through each myArr
For Each W In V 'loop through the contents of each myArr
If Not dict.exists(W) Then dict.Add W, W
Next W
Next V
uniqueArr = dict.keys
End Function
Sub tester()
Dim myArray1, myArray2, myArray3, myArray4, myArray5
myArray1 = Array(1, 2, 3, 4)
myArray2 = Array(5, 6, 7, 8)
myArray3 = Array(9, 10, 11, 12, 13, 14)
myArray4 = Array(15, 16)
myArray5 = Array(1, 3, 25, 100)
Dim mainArray
mainArray = uniqueArr(myArray1, myArray2, myArray3, myArray4, myArray5)
End Sub
If you run Tester, you will see mainArray contains:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
25
100
Using your data this is how to create one array out of many:
Public Sub TestMe()
Dim myA, myB, myC, myD, myE
myA = Array(1, 2, 3, 4)
myB = Array(5, 6, 7)
myC = Array(8, 9)
myD = Array(10, 11, 12, 13, 14)
myE = Array(101, 102, 103)
Dim myCombine As Variant
Dim myNew() As Variant
Dim myElement As Variant
Dim myArr As Variant
Dim cnt As Long
myCombine = Array(myA, myB, myC, myD, myE)
For Each myArr In myCombine
For Each myElement In myArr
ReDim Preserve myNew(cnt)
myNew(cnt) = myElement
cnt = cnt + 1
Next
Next
For cnt = LBound(myNew) To UBound(myNew)
Debug.Print myNew(cnt)
Next cnt
End Sub
The "building" of the new array is facilitated through ReDim Preserve, which keeps the old values in the array whenver the dimension of the array changes. And if you want to do something with these arrays, you may use 3 nested loops (a bit slow) and have some check:
Dim cnt2 As Long
For cnt = LBound(myNew) To UBound(myNew)
For cnt2 = LBound(myCombine) To UBound(myCombine)
For Each myElement In myCombine(cnt2)
If myElement = myNew(cnt) Then
Debug.Print myElement & vbTab & " from " & vbTab & cnt2
End If
Next myElement
Next cnt2
Next cnt
This is what you get on the immediate window:
1 from 0
2 from 0
3 from 0
4 from 0
5 from 1
6 from 1
7 from 1
8 from 2
9 from 2
10 from 3
11 from 3
12 from 3
13 from 3
14 from 3
101 from 4
102 from 4
103 from 4
Alternate 'brick-by-brick' approach.
Option Explicit
Sub combineArrays()
Dim myArray1 As Variant, myArray2 As Variant, myArray3 As Variant
Dim myArray4 As Variant, myArray46 As Variant
ReDim mainArray(0) As Variant
myArray1 = Array(1, 2, 3, 4)
myArray2 = Array(5, 6, 7)
myArray3 = Array(8, 9)
myArray4 = Array(10, 11, 12, 13, 14)
'...
myArray46 = Array(101, 102, 103)
mainArray = buildMainArray(myArray1, mainArray)
mainArray = buildMainArray(myArray2, mainArray)
mainArray = buildMainArray(myArray3, mainArray)
mainArray = buildMainArray(myArray4, mainArray)
mainArray = buildMainArray(myArray46, mainArray)
ReDim Preserve mainArray(UBound(mainArray) - 1)
Debug.Print Join(mainArray, ",")
End Sub
Function buildMainArray(arr As Variant, marr As Variant)
Dim i As Long
For i = LBound(arr) To UBound(arr)
marr(UBound(marr)) = arr(i)
ReDim Preserve marr(UBound(marr) + 1)
Next i
buildMainArray = marr
End Function
The issue with using Redim Preserve to combine arrays is it can be an expensive operation, since you're basically re-creating the array everytime it's called. Since you have 46 arrays you're combining, you may very well be waiting a while.
Instead, you can loop over the arrays to figure out the total number of elements you need, dimension out your master array, then loop over the arrays again to do the actual assignment/merging. Something like this:
' encapsulates code to determine length of an individual array
' note that because arrays can have different LBounds in VBA, we can't simply use
' Ubound to determine array length
Public Function GetArrayLength(anArray As Variant) As Integer
If Not IsArray(anArray) Then
GetArrayLength = -1
Else
GetArrayLength = UBound(anArray) - LBound(anArray) + 1
End If
End Function
Public Function CombineArrays(ParamArray arraysToMerge() As Variant) As Variant
' index for looping over the arraysToMerge array of arrays,
' and then each item in each array
Dim i As Integer, j As Integer
' variable to store where we are in the combined array
Dim combinedArrayIndex As Integer
' variable to hold the number of elements in the final combined array
Dim CombinedArrayLength As Integer
' we don't initialize the array with an array-length until later,
' when we know how long it needs to be.
Dim combinedArray() As Variant
' we have to loop over the arrays twice:
' First, to figure out the total number of elements in the combined array
' second, to actually assign the values
' otherwise, we'd be using Redim Preserve, which can get quite expensive
' because we're creating a new array everytime we use it.
CombinedArrayLength = 0
For i = LBound(arraysToMerge) To UBound(arraysToMerge)
CombinedArrayLength = CombinedArrayLength + GetArrayLength(arraysToMerge(i))
Next i
' now that we know how long the combined array has to be,
' we can properly initialize it.
' you can also use the commented code instead, if you prefer 1-based arrays.
ReDim combinedArray(0 To CombinedArrayLength - 1)
' Redim combinedArray(1 to CombinedArrayLength)
' now that the combinedarray is set up to store all the values in the arrays,
' we can begin actual assignment
combinedArrayIndex = LBound(combinedArray)
For i = LBound(arraysToMerge) To UBound(arraysToMerge)
For j = LBound(arraysToMerge(i)) To UBound(arraysToMerge(i))
combinedArray(combinedArrayIndex) = arraysToMerge(i)(j)
combinedArrayIndex = combinedArrayIndex + 1
Next j
Next i
' assign the function to the master array we've been using
CombineArrays = combinedArray
End Function
To use this function, you'd do something like the following:
Public Sub TestArrayMerge()
Dim myArray1() As Variant
Dim myArray2() As Variant
Dim myArray3() As Variant
Dim myArray4() As Variant
Dim combinedArray As Variant
myArray1 = Array(1, 2, 3, 4)
myArray2 = Array(5, 6, 7)
myArray3 = Array(8, 9)
myArray4 = Array(10, 11, 12, 13, 14)
combinedArray = CombineArrays(myArray1, myArray2, myArray3, myArray4)
If IsArray(combinedArray) Then
Debug.Print Join(combinedArray, ",")
End If
End Sub
Regarding your last bit, that you're using an inner loop to combine the values in your final combined array: Your inner loop doesn't need to start at LBound(myArray). For any value of i, you've already compared it to the elements before it (e.g., when i = 2, it's already been compared to the first element). So you really just need:
For i = LBound(combinedArray) To UBound(combinedArray) - 1
For j = i + 1 To UBound(combinedArray)
' do whatever you need
Next j
Next i
Perhaps this ...
'To determine if a multi-dimension array is allocated (or empty)
'Works for any-dimension arrays, even one-dimension arrays
Public Function isArrayAllocated(ByVal aArray As Variant) As Boolean
On Error Resume Next
isArrayAllocated = IsArray(aArray) And Not IsError(LBound(aArray, 1)) And LBound(aArray, 1) <= UBound(aArray, 1)
Err.Clear: On Error GoTo 0
End Function
'To determine the number of items within any-dimension array
'Returns 0 when array is empty, and -1 if there is an error
Public Function itemsInArray(ByVal aArray As Variant) As Long
Dim item As Variant, UBoundCount As Long
UBoundCount = -1
If IsArray(aArray) Then
UBoundCount = 0
If isArrayAllocated(aArray) Then
For Each item In aArray
UBoundCount = UBoundCount + 1
Next item
End If
End If
itemsInArray = UBoundCount
End Function
'To determine the number of dimensions of an array
'Returns -1 if there is an error
Public Function nbrDimensions(ByVal aArray As Variant) As Long
Dim x As Long, tmpVal As Long
If Not IsArray(aArray) Then
nbrDimensions = -1
Exit Function
End If
On Error GoTo finalDimension
For x = 1 To 65536 'Maximum number of dimensions (size limit) for an array that will work with worksheets under Excel VBA
tmpVal = LBound(aArray, x)
Next x
finalDimension:
nbrDimensions = x - 1
Err.Clear: On Error GoTo 0
End Function
'****************************************************************************************************
' To merge an indefinite number of one-dimension arrays together into a single one-dimension array
' Usage: mergeOneDimArrays(arr1, arr2, arr3, ...)
' Returns an empty array if there is an error
' Option Base 0
'****************************************************************************************************
Public Function mergeOneDimArrays(ParamArray infArrays() As Variant) As Variant
Dim x As Long, y As Long, UBoundCount As Long, newUBoundCount As Long
Dim tmpArr As Variant, allArraysOK As Boolean
UBoundCount = 0
allArraysOK = True
For x = LBound(infArrays) To UBound(infArrays)
If Not IsArray(infArrays(x)) Or Not nbrDimensions(infArrays(x)) = 1 Then
allArraysOK = False
Exit For
End If
UBoundCount = UBoundCount + itemsInArray(infArrays(x))
Next x
If allArraysOK Then
ReDim tmpArr(0 To UBoundCount - 1)
UBoundCount = 0
For x = LBound(infArrays) To UBound(infArrays)
For y = LBound(infArrays(x)) To UBound(infArrays(x))
tmpArr(UBoundCount) = infArrays(x)(y)
UBoundCount = UBoundCount + 1
Next y
Next x
newUBoundCount = itemsInArray(tmpArr)
If newUBoundCount = UBoundCount Then
mergeOneDimArrays = tmpArr
Else
mergeOneDimArrays = Array()
End If
Erase tmpArr
Else
mergeOneDimArrays = Array()
End If
End Function
If you are working with one-dimensional arrays you could use a collection instead. It is much better at handling dynamic sizing.
You can declare a collection and then add each of the elements in the arrays to it. Then you will have one large list with all of the values.
Dim coll As New Collection
coll.Add MyArray(j)
Here is a good to collections introduction:
https://excelmacromastery.com/excel-vba-collections/
I use the code hereunder to calculate max values as described in this post (vba max value of group of values). The code works great but once I have more than 65k lines I get a data type mismatch when trying to pase the array:
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
Could somebody help me to slice the array in chunks. I have tried to get it working myself but without any luck.
Sub FillGroupsMax()
Dim lColumn As Long
Dim sht As Worksheet
Dim groupsArray As Variant 'array with all group infomation
Dim groupsSeen As Variant 'array with group infomation already seen
Application.ScreenUpdating = False 'stop screen updating makes vba perform better
Set sht = ThisWorkbook.Worksheets("import")
Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious) 'last cell with value in column A
lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column
groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
'collect all the information on the Sheet into an array
'Improves performance by not visiting the sheet
For dRow = 2 To last.Row 'for each of the rows skipping header
'check if group as already been seen
If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
'if it has been seen/calculated attribute value
'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
Else
'if it hasn't been seen then find max
'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)
'array construction from empty
If IsEmpty(groupsSeen) Then
ReDim groupsSeen(0)
'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
'attribute value to array
Else
ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
End If
End If
Next
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
'reactivate Screen updating
Application.ScreenUpdating = True
End Sub
Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double
'for each in array
For n = 1 To UBound(groupsArray)
'if its the same group the Max we seen so far the record
If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
maxSoFar = groupsArray(n, lColumn - 1)
End If
Next
'set function value
getMax = maxSoFar
End Function
Function inArrayValue(group As String, groupsSeen As Variant) As Double
'set function value
inArrayValue = 0
'if array is empty then exit
If IsEmpty(groupsSeen) Then Exit Function
'for each in array
For n = 0 To UBound(groupsSeen)
'if we find the group
If groupsSeen(n)(0) = group Then
'set function value to the Max value already seen
inArrayValue = groupsSeen(n)(1)
'exit function earlier
Exit Function
End If
Next
End Function
You can write a helper function to use instead of Application.Index
Bonus - it will be much faster than using Index (>5x)
Sub Tester()
Dim arr, arrCol
arr = Range("A2:J80000").Value
arrCol = GetColumn(arr, 5) '<< get the fifth column
Range("L2").Resize(UBound(arrCol, 1), 1).Value = arrCol
End Sub
'extract a single column from a 1-based 2-D array
Function GetColumn(arr, colNumber)
Dim arrRet, i As Long
ReDim arrRet(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
arrRet(i, 1) = arr(i, colNumber)
Next i
GetColumn = arrRet
End Function
EDIT - since QHarr asked about timing here's a basic example
Sub Tester()
Dim arr, arrCol, t, i as long
arr = Range("A2:J80000").Value
t = Timer
For i = 1 to 100
arrCol = GetColumn(arr, 5) '<< get the fifth column
Next i
Debug.print Timer - t '<<# of seconds for execution
End Sub
Below, whilst not as tidy as could be, is a way to process an array in chunks and Index to access a column and write out to the sheet.
I populated two columns (A:B) with data. Both had 132,000 rows, populated incrementally, with values from 1 to 132,000 in each column for my test run.
You can fiddle with cutOff to get the chunk size just below the point where the fail happens.
The code below is simply to demonstrate the principle of looping in batches, upto the set cutoff in each batch, until all rows have been processed.
Option Explicit
Public Sub WriteArrayToSheet()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Worksheets("Sheet1") 'change as appropriate
Dim myArr() 'dynamic array
myArr = sht.Range("A1").CurrentRegion.Value 'you may want a more robust method
Dim cutOff As Long 'the max value - what ever it is before error occurs
cutOff = 1000
Dim totalRows As Long 'total rows in array read in from sheet
totalRows = UBound(myArr, 1)
Dim totalArraysNeeded As Long
'Determine how many lots of cutOff chunks there are in the total number of array rows
totalArraysNeeded = Application.WorksheetFunction.Ceiling(totalRows / cutOff, 1)
Dim rotations As Long 'number of times to loop original array to handle all rows
Dim rowCountTotal As Long
Dim rowCount As Long
Dim tempArr() 'this will hold the chunk of the original array
Dim rowCounter As Long
Dim lastRow As Long
Dim nextRow As Long
Dim i As Long
Dim j As Long
Dim numRows As Long
rotations = 1
Do While rotations < totalArraysNeeded
If rotations < totalArraysNeeded - 1 Then
ReDim tempArr(1 To cutOff, 1 To UBound(myArr, 2)) 'size chunk array
numRows = cutOff
Else
numRows = totalRows - rowCountTotal
ReDim tempArr(1 To numRows, 1 To UBound(myArr, 2)) 'size chunk array
End If
For i = 1 To numRows
rowCount = 1 'rows in this chunk looped
rowCountTotal = rowCountTotal + 1 'rows in original array looped
For j = LBound(myArr, 2) To UBound(myArr, 2)
tempArr(i, j) = myArr(rowCountTotal, j)
Next j
rowCount = rowCount + 1
Next i
With sht
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Column where I am writing the sliced column out to
End With
If lastRow = 1 Then
nextRow = 1
Else
nextRow = lastRow + 1
End If
sht.Range("E" & nextRow).Resize(UBound(tempArr, 1), 1) = Application.Index(tempArr, , 1) 'write out to sheet
rotations = rotations + 1
Loop
End Sub
As #Tim suggested, the best way to slice a large array is use a loop to copy the column.
Though in your case, most of the processing time is spent on computing the maximum since your code is using a nested loop.
If you want to reduce significantly the processing time, then use a dictionary:
Sub Usage
GetMaxByGroupTo _
sourceGroups := ThisWorkbook.Range("Sheet1!A2:A100"), _
sourceValues := ThisWorkbook.Range("Sheet1!B2:B100"), _
target := ThisWorkbook.Range("Sheet1!C2")
End Sub
Sub GetMaxByGroupTo(sourceGroups As Range, sourceValues As Range, target As Range)
Dim dict As Object, groups(), values(), r As Long, max
Set dict = CreateObject("Scripting.Dictionary")
groups = sourceGroups.Value2
values = sourceValues.Value2
' store the maximum value of each group in a dictionary for an efficient lookup '
For r = Lbound(groups) to Ubound(groups)
max = dict(groups(r, 1))
If VarType(max) And values(r, 1) <= max Then Else dict(groups(r, 1)) = values(r, 1)
Next
' build and copy the result array to the sheet '
For r = Lbound(groups) to Ubound(groups)
values(r, 1) = dict(groups(r, 1))
Next
target.Resize(Ubound(groups), 1).Value2 = values
End Sub