Sumproduct with mapping multiple rows - excel

I want to write excel formula that will sum the values based on a match of the rows. The cells to be matched can occur multiple times and basing on the Mapping legend they should return the sum of values.
In the yellow cells I am trying to calculate sum of values in range B9:B21 based on a match of the names in G3:G8 according to Mapping legend to Item1, then Item2 and Item 3.
I got already answer on how to sum the values if array to be summed is the same as Mapping legend. But now my array to be summed in extended and SUMPRODUCT formula does not work anymore:
Is there a solution to that?

This needs improving but is a starter user defined function that can be used in the sheet.
function GetSum
arg1 item String The item to match against e.g. Item2
arg2 sourceData Range The data range to sum over according to item
arg3 lookup Range The data range containing the mapping (2 columns wide)
Public Function GetSum(ByVal item As String, sourceData As Range, lookup As Range) As Variant
If lookup.Columns.Count <> 2 Then GetSum = CVErr(xlErrNA)
Dim lookupDict As Object, arr(), arr2(), i As Long, finalValue As Double
Set lookupDict = CreateObject("Scripting.Dictionary")
If lookup.Cells.Count = 1 Then
ReDim arr(1, 1)
arr(1, 1) = lookup.Value
Else
arr = lookup.Value
End If
If sourceData.Cells.Count = 1 Then
ReDim arr2(1, 1)
arr2(1, 1) = sourceData.Value
Else
arr2 = sourceData.Value
End If
For i = LBound(arr, 1) To UBound(arr, 1)
lookupDict(arr(i, 2)) = arr(i, 1)
Next i
For i = LBound(arr2, 1) To UBound(arr2, 1)
If lookupDict.exists(arr2(i, 1)) Then
If lookupDict(arr2(i, 1)) = item Then
finalValue = finalValue + arr2(i, 2)
End If
End If
Next i
GetSum = finalValue
End Function
Data:

Fix your formula :
=SUMPRODUCT(--(NOT(ISERROR(MATCH(B11:B20,F6:F9,0)))),C11:C20)
As in the picture (can't change excel language sosad) :
As a general guideline for this an future projects, I would recommend as it's been said to use a helper column to tag your items and simplify the formula greatly :

Related

Is there an easy way to add a string to beginning and end of VBA array

If i have this code is there a simple way to add item1 to the beginning of the array and item2 to the end of the array in VBA?
The below code currently runs.
Dim nameArray as variant
Dim k as integer
Dim item1 as string
Dim item2 as string
k = 1
nameArray = Range(Cells(2, 3), Cells(5, 3)).Value
For Each i In nameArray
newcol = baseclmn + k
tblComp.ListColumns.Add(newcol).Name = i
k = k + 1
Next I
Thanks for any help you can offer
You could start off with a larger array and replace the first and last items.
Dim nameArray as variant
nameArray = Range(Cells(1, 3), Cells(6, 3)).Value
nameArray(LBound(nameArray), 1) = "Item1"
nameArray(UBound(nameArray), 1) = "Item2"
If you want to expand the array, perhaps something like this:
nameArray = Range(Cells(2, 3), Cells(5, 3)).Value
Dim newArray
ReDim newArray(1 to Ubound(nameArray, 1) + 2, 1 to Ubound(nameArray, 2)) 'add two rows
newArray(1, 1) = "item1"
newArray(Ubound(newArray, 1), 1) = "item2"
Dim i As Long
For i = LBound(nameArray, 1) To Ubound(nameArray, 1)
newArray(i + 1, 1) = nameArray(i, 1)
Next
Explanation:
nameArray is a 2-dimensional array, where the first dimension corresponds to rows and the second to columns. Note that this array is one-based, i.e. the first index is 1 and not 0.
The code uses ReDim to create a new array, containing
Two more rows than nameArray
The same number of columns as nameArray.
Then it adds the first and last items:
newArray(1, 1) = "item1": 1, 1 corresponds to the first row, first column.
newArray(Ubound(newArray, 1), 1) = "item2": Ubound(newArray, 1) corresponds to the last row, and 1 again corresponds to the first column.
Finally it uses a loop to read the items from nameArray into the middle of newArray.
Further helpful reading includes Arrays and Ranges in VBA.
You can enlarge (and/or restructure) the existing (vertical) nameArray in one go
via an undocumented feature of Application.Index()
using either the new Sequence() function (available since MS 365!) or a workaround via row evaluation (commented out in comment)
to pass a whole array(!) of row numbers (rowArr) as argument (instead of a single row index):
newArray = Application.Index(nameArray, rowArr, 1)
where rowArr is a vertical array of sequential row numbers reflecting the currently existing indices, and 1 the unchanged column index.
Sub TopBottomAdditions()
'0. define 1-based 2-dim data field
Dim nameArray
nameArray = Sheet1.Range(Cells(2, 3), Cells(5, 3)).Value 'i.e. data field of cells C2:C5
'1a create a sequence (array) ranging from 0 to elements count plus +1 (2 new elems)
Dim rowArr ' {0,1,2,..n,n+1}
rowArr = WorksheetFunction.Sequence(UBound(nameArray) + 2, 1, 0)
''>workaround if you don't dispose of version MS 365
' rowArr = Evaluate("row(1:" & UBound(nameArray) + 2 & ")-1")
'1b keep existing values in rows 1..n and add top+bottom element
'note: index 0 fetches element of existing index 1, n+1 gets a temporary error value
Dim newArray
newArray = Application.Index(nameArray, rowArr, 1)
'1c insert new top & bottom values
newArray(1, 1) = "Top value" ' overwrites New elem no 1
newArray(UBound(newArray), 1) = "Bottom value" ' writes New last elem
End Sub
Syntax of Sequence()
=SEQUENCE(rows,[columns],[start],[step])

Excel index match with a condition to choose a specific column in a 3d matrix (formula or VBA)

I have two tables in Excel, one with categories and listings, and another with points based on the category and listing threshold. It goes as follows:
Categories table:
ID
CATEGORY
LISTINGS
Points
001
A
56
002
C
120
003
A
4
004
B
98
Points table:
Category
tier1
tier2
tier3
A
Tier 1
Tier 2
Tier 3
Range
1-30
31-90
91-
Points
10
20
30
B
Tier 1
Tier 2
Tier 3
Range
1-25
26-100
101-
Points
10
20
30
C
Tier 1
Tier 2
Tier 3
Range
1-40
41-80
81-
Points
10
20
30
I started with an INDEX MATCH formula pointing at the points:
=INDEX(Points!A1:D11, MATCH(Categories!B2, Points!A1:A11, 0)+2)
--> the +2 is to get the points directly
I also though of evaluating the thresholds with this formula:
=IF(Categories!C2 >= NUMBERVALUE(LEFT(Points!D3, FIND("-",Points!D3)-1)),Points!D4, IF(Categories!C2 >=NUMBERVALUE(LEFT(Points!C3, FIND("-",Points!C3)-1)),Points!C4, Points!B4))
I thought that the else if the if would make it faster.
Could someone help me populate the Points column in the Categories table? VBA code is also acceptable. The tables are in different sheets.
José, your original Match formula is the right starting place. It locates the particular sub-table to do a further lookup on. But in order to make this formula a whole lot simpler, can we change the ranges (1-30, 31-90, 91-) to have just their starting points (1, 31, 91)? If we do that simple change then we can use the approximate lookup feature of HLookup to easily and compactly specify the Lookup:
=HLookup($C2,Offset(Points!$A$1,Match($B2,Points!$A:$A,0),1,2,3),2,True)
In the middle of this formula you can see your original Match function to locate the correct sub-table based on the category. We need to feed that start point to OFFSET() to create a table range useful to the HLookup. Offset takes an anchor cell reference (top left of the Points table), number of rows to count down from there (result of the Match), number of columns to the right (1), the number of rows in the range (2), and the number of columns in the range (3).
The Hlookup is just like a VLookup, but for tables arranged left-to-right not top-to-bottom. The True as the last parameter is very important as it tells HLookup to use the range lookup instead of an exact match.
A slightly verbose formula which takes the data as originally formatted (using Excel 365 Let):
=LET(ranges,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0),0),
leftRanges,VALUE(LEFT(ranges,FIND("-",ranges)-1)),
points,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0)+1,0),
INDEX(points,MATCH(C2,leftRanges)))
As it's urgent this is what I got but I cannot continue before tomorrow. Assuming you can at least put the tiers next to the category (A on same line as tiers) this will get you the first tier. You just need to copy the whole formula in the "nextCol", with minor modifications to get the next tiers.
if you really cannot change the source you need to add an additional offset in the first match.
=IF(AND(D1>NUMBERVALUE(LEFT(INDIRECT("B"&MATCH(E1,A:A,0)),FIND("-",INDIRECT("B"&MATCH(E1,A:A,0)))-1)),D1<NUMBERVALUE(RIGHT(INDIRECT("B"&MATCH(E1,A:A,0)),2))),INDEX(B:D,MATCH(E1,A:A,0)+1,1),"nextCol")
Option Explicit
Sub Score()
Dim wsP As Worksheet, wsC As Worksheet, dict
Dim iLastRow As Long, r As Long, i As Long, j As Integer
Dim sCat As String, iListing As Integer
Dim data, ar
Set wsP = Sheets("Points")
Set wsC = Sheets("Categories")
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row
data = wsC.Range("A1:D" & iLastRow).Value2
' category to row lookup
For i = 1 To UBound(data)
If data(i, 1) = "Range" Then
dict.Add Trim(data(i - 1, 1)), i ' range
End If
Next
' scan points
iLastRow = wsP.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To iLastRow
sCat = Trim(wsP.Cells(r, "B"))
iListing = wsP.Cells(r, "C")
If dict.exists(sCat) Then
i = dict(sCat)
For j = 4 To 2 Step -1
ar = Split(data(i, j), "-") ' lower-upper limit
If iListing >= ar(0) Then ' check lower limit
' update points
wsP.Cells(r, "D") = data(i + 1, j) ' points
Exit For
End If
Next
Else
MsgBox "No match '" & sCat & "'", vbCritical, "ERROR row " & r
End If
Next
MsgBox "done"
End Sub
Please, try the next code. It uses arrays and should be very fast, working only in memory. Please use your sheets when setting shC and shP as your real sheets. I only use the active sheet and the next one for testing reason:
Sub GetPoints()
Dim shC As Worksheet, shP As Worksheet, lastRC As Long, lastRP As Long, arrBC, arrP, arrPP, arrFin
Dim i As Long, j As Long, p As Long, k As Long
Set shC = ActiveSheet 'use here your Categories sheet
Set shP = shC.Next 'use here your Points sheet
lastRC = shC.Range("A" & shC.rows.count).End(xlUp).row
lastRP = shP.Range("A" & shP.rows.count).End(xlUp).row
arrBC = shC.Range("B2:C" & lastRC).Value 'put the range B:C in an array
arrP = shP.Range("A2:D" & lastRP).Value 'put all the range in an array
ReDim arrFin(1 To UBound(arrBC), 1 To 1) 'redim the array to keep processed values
For i = 1 To UBound(arrBC) 'iterate between Categ array elements:
For j = 1 To UBound(arrP) 'iterate between Points array elements:
If arrP(j, 1) = arrBC(i, 1) Then 'if Category is found:
For p = 2 To 4 'iterate between the next array row elements
arrPP = Split(arrP(j + 1, p), "-") 'split the element by "-" to determine the interval
If arrPP(1) <> "" Then 'for the tier3 case:
If arrBC(i, 2) >= CLng(arrPP(0)) And arrBC(i, 2) <= CLng(arrPP(1)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
Else 'for the tier1 and tier2 cases:
If arrBC(i, 2) >= CLng(arrPP(0)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
End If
Next p
End If
Next j
Next i
'drop the final array result at once:
shC.Range("D2").Resize(UBound(arrFin), 1).Value = arrFin
End Sub

Nesting ParamArrays when declaring Excel VBA functions like SUMIFS?

Consider the following example: Lets say you want to make a function "JoinIfs" that works just like SUMIFS except instead of adding the values in the SumRange, it concatenates the values in "JoinRange". Is there a way to nest the ParamArray as it seems to be done in SUMIFS?
SUMIFS(sum_range, criteria_range1, criteria1, [criteria_range2, criteria2], ...)
I imagine the declaration should look something like this:
Function JoinIfs(JoinRange As Variant, _
Delim As String, _
IncludeNull As Boolean, _
ParamArray CritArray(CriteriaRange As Variant, Criteria As Variant)) As String
But nothing I try seems to compile and there might not be a way to nest ParamArrays. But the existence of functions like SUMIFS and COUNTIFS seems to suggest there might be a way to nest the ParamArrays.
This question duplicates AlexR's question Excel UDF with ParamArray constraint like SUMIFS. But that was posted a few years ago with no response so either the question didn't get enough attention or it was misunderstood.
Edit for clarification: This question is specifically about nesting ParamArrays. I'm not trying to find alternative methods of achieving the outcome of the example above. Imagine nesting ParamArrays on a completely different fictional function like "AverageIfs"
As per the documentation for the Function statement and Sub statement, a Function or Sub can only contain 1 ParamArray, and it must be the last argument.
However, you can pass an Array as an Argument to a ParamArray. Furthermore, you can then check how many elements are in the ParamArray, and throw an error if it isn't an even number. For example, this demonstration takes a list of Arrays, and which element in that array to take, and outputs another array with the results:
Sub DemonstrateParamArray()
Dim TestArray As Variant
TestArray = HasParamArray(Array("First", "Second"), 0)
MsgBox TestArray(0)
Dim AnotherArray As Variant
AnotherArray = Array("Hello", "World")
TestArray = HasParamArray(AnotherArray, 0, AnotherArray, 1)
MsgBox Join(TestArray, " ")
End Sub
Function HasParamArray(ParamArray ArgList() As Variant) As Variant
Dim ArgumentCount As Long, WhichPair As Long, Output() As Variant, WhatElement As Long
ArgumentCount = 1 + UBound(ArgList) - LBound(ArgList)
'Only allow Even Numbers!
If ArgumentCount Mod 2 = 1 Then
Err.Raise 450 '"Wrong number of arguments or invalid property assignment"
Exit Function
End If
ReDim Output(0 To Int(ArgumentCount / 1) - 1)
For WhichPair = LBound(ArgList) To ArgumentCount + LBound(ArgList) - 1 Step 2
WhatElement = ArgumentCount(WhichPair + 1)
Output(Int(WhichPair / 2)) = ArgumentCount(WhichPair)(WhatElement)
Next WhichPair
HasParameterArray = Output
End Function
(A list of built-in error codes for Err.Raise can be found here)
It seems like nesting a ParamArray is not possible.
I was hoping to get a function that looks like Excel's built in functions.
SUMIFS, for example seems to group pairs of parameters in a very neat way.
Based on the inputs of some users I made the following Function which seems to work quite well.
Function SJoinIfs(JoinRange As Variant, Sep As String, IncludeNull As Boolean, ParamArray CritArray() As Variant) As Variant
'Concatenates text based on multple criteria similar to SUMIFS.
'Sizes of ranges CritArray (0, 2, 4 ...) must match size of range JoinRange. CritArray must have an even amount of elements
'Elements of CritArray (1, 3, 5 ...) must be single values
Set JoinList = CreateObject("System.Collections.Arraylist")
'Set FinalList = CreateObject("System.Collections.Arraylist")
For Each DataPoint In JoinRange
JoinList.Add (CStr(DataPoint))
Next
JoinArray = JoinList.ToArray
CriteriaCount = UBound(CritArray) + 1
If CriteriaCount Mod 2 = 0 Then
CriteriaSetCount = Int(CriteriaCount / 2)
Set CriteriaLists = CreateObject("System.Collections.Arraylist")
Set CriteriaList = CreateObject("System.Collections.Arraylist")
Set MatchList = CreateObject("System.Collections.Arraylist")
For a = 0 To CriteriaSetCount - 1
CriteriaList.Clear
For Each CriteriaTest In CritArray(2 * a)
CriteriaList.Add (CStr(CriteriaTest))
Next
If CriteriaList.count <> JoinList.count Then 'Ranges are different sizes
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
MatchList.Add (CStr(CritArray((2 * a) + 1)))
CriteriaLists.Add (CriteriaList.ToArray)
Next
JoinList.Clear
For a = 0 To UBound(JoinArray)
AllMatch = True
For b = 0 To MatchList.count - 1
AllMatch = (MatchList(b) = CriteriaLists(b)(a)) And AllMatch
Next
If AllMatch Then JoinList.Add (JoinArray(a))
Next
SJoinIfs = SJoin(Sep, IncludeNull, JoinList)
Else 'Criteria Array Size is not even
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
End Function
This function makes use of another function SJoin() which I adapted some time ago based on the answer provided by Lun in his answer to How to replicate Excel's TEXTJOIN function in VBA UDF that allows array inputs.
I have adapted this Function to include the use of Numericals, VBA Arrays and Arraylists as well.
On Error Resume Next
'Sep is the separator, set to "" if you don't want any separator. Separator must be string or single cell, not cell range
'TxtRng is the content you want to join. TxtRng can be string, single cell, cell range or array returned from an array function. Empty content will be ignored
Dim OutStr As String 'the output string
Dim i, j, k, l As Integer 'counters
Dim FinArr(), element As Variant 'the final array and a temporary element when transfering between the two arrays
'Go through each item of TxtRng(), depending on the item type, transform and put it into FinArray()
i = 0 'the counter for TxtRng
j = 0 'the counter for FinArr
k = 0: l = 0 'the counters for the case of array from Excel array formula
Do While i < UBound(TxtRng) + 1
If TypeName(TxtRng(i)) = "String" Then 'specified string like "t"
ReDim Preserve FinArr(0 To j)
FinArr(j) = "blah"
FinArr(j) = TxtRng(i)
j = j + 1
ElseIf TypeName(TxtRng(i)) = "Range" Then 'single cell or range of cell like A1, A1:A2
For Each element In TxtRng(i)
ReDim Preserve FinArr(0 To j)
FinArr(j) = element
j = j + 1
Next
ElseIf TypeName(TxtRng(i)) = "Variant()" Then 'array returned from an Excel array formula
For k = LBound(TxtRng(0), 1) To UBound(TxtRng(0), 1)
For l = LBound(TxtRng(0), 2) To UBound(TxtRng(0), 2)
ReDim Preserve FinArr(0 To j)
FinArr(j) = TxtRng(0)(k, l)
j = j + 1
Next
Next
Else
TJoin = CVErr(xlErrValue)
Exit Function
End If
i = i + 1
Loop
'Put each element of the new array into the join string
For i = LBound(FinArr) To UBound(FinArr)
If FinArr(i) <> "" Then 'Remove this line if you want to include empty strings
OutStr = OutStr & FinArr(i) & Sep
End If
Next
TJoin = Left(OutStr, Len(OutStr) - Len(Sep)) 'remove the ending separator
End Function
Thanks to all who contributed to this question.

Multidimensional array and comparing values in each array and give result for each array

I following program to call values to array and compare the values and give a result. I asked this question in another thread.
VPA program for compare values in array and give a result (MS Excel)
Here we can see that one dimensional array to which values are assigned. But i want to call values from multiple column when a IF condition is true
Dim arr as variable
For i = 1 to u
if mycondition1 then
x = Cells(i, 2).Value
m = Application.WorksheetFunction.CountIf(Range("B4:B" & u), x)
ReDim arr(1 To m)
For j = 1 to u
if mycondition2 then
arr(y) = Cells(j, 27)
End If
Next j
For one dimensional array i use code arr(y) = Cells(j, 27). Here i want to call values from column 27. Like this i want to assign values from different column (Say 27, 28, 29 upto 32). Instead of create six arrays, I know i can use two dimensional array say arr(1 to m, 1 to 6) and get values assigned from cells of each column and rows. But don't know how to compare values for each column similar to codes given below (which is comparison for one column values). I forced to write one comparison codes for each column. So my coding lines are more and take lots of time to execute. And i want do the for loop upto u=100.000 rows. Is there any easy way
w = arr()
Res = Application.Match(Array("No", "-"), w, 0)
For Each r In Res
ThisWorkbook.Worksheets("Sheet1").Cells(i, 27) = "X"
If Not IsError(r) Then
ThisWorkbook.Worksheets("Sheet1").Cells(i, 27) = "O"
Exit For
End If
Next r
Erase arr()
Exitsinglepart:
End If
Next i
End Sub
Please help me how to rewrite this code for comparing values called from each column.
Firstly, I must say that I don't understand what you want. Secondly, I feel that you are going about it the wrong way. In view of my first observation, I apologise. This is the way I would go about it:-
Private Sub TestIsYes()
Dim Arr As Variant
Arr = Array("Yes", "-", "Yes", "yes", "Yes")
Debug.Print IsYes(Join(Arr, ","))
End Sub
Function IsYes(StrArr As String) As String
' 25 Mar 2017
Dim Fun As Boolean
Fun = CBool(InStr(1, StrArr, "no", vbTextCompare))
If Not Fun Then
Fun = CBool(InStr(StrArr, "-"))
End If
IsYes = Split("No Yes")(CInt(Fun) + 1)
End Function
As you see, the function IsYes receives a string like "Yes,-,yes,Yes" and returns "Yes" or "No" based upon your criteria. You can test the function by changing the elements of the parameter array in the sub TestIsYes. TestIsYes could write this result directly into any cell on the worksheet.
This function might be modified in whatever way you need, but it remains at the core of your project. The question therefore is how to produce the string passed to IsYes as an argument. You wish (or should wish, perhaps) produce this string from a range. The next function does that.
Private Function RangeToString(Rng As Range) As String
' 25 Mar 2017
Dim Fun As String
Dim Arr As Variant
Dim R As Long, C As Long ' rows / columns
Arr = Rng.Value
With Arr
For R = LBound(Arr) To UBound(Arr)
For C = LBound(Arr, 2) To UBound(Arr, 2)
Fun = Fun & Arr(R, C) & ","
Next C
Next R
End With
RangeToString = Fun
End Function
Note that any array produced from an Excel range is 3-dimensional, even if it was taken from a single column. Therefore the above function produces a string of the kind required by IsYes from any range, regardless of how many columns it has.
I have set up a test in the worksheet range B2:C5 (4 rows, 2 columns - expand or reduce this as you wish), filled with your criteria. I created the following function using the functions explained before.
Function UDFIsYes(Rng As Range) As String
' 25 Mar 2017
UDFIsYes = IsYes(RangeToString(Rng))
End Function
You can call this function from the worksheet entering =UDFIsYes(B2:C5). You can call the same function from a VBA procedure like the following.
Private Sub TestUDF()
Debug.Print UDFIsYes(ActiveSheet.Range(Cells(2, 2), Cells(5, 3)))
End Sub
I hope this helps. Let me know where this information falls short of what you need.

Adding a table of data to a dictionary excel vba

I'm brand new to using dictionaries and could do with a bit of help. I've got a table of data in range A1:C4
A B C
1 4 7
2 5 8
3 6 9
Is there any way of adding this tables directly into a dictionary?
Thanks in advance
Dim d As Scripting.Dictionary
Dim r As Excel.Range
Dim c As Excel.Range
Set d = New Scripting.Dictionary
Set r = Range("a1:c4")
For Each c In r.Cells
d.Add CStr(c.Address), c.Value
Next c
I think what you're probably looking for is a Multidimensional Array
A standard Array will hold a series of values in a list, and the value of any point in this list can be referenced, for example:
myArray = Array("One", "Two", "Three")
'The first value in an array is at position 0 unless otherwise specified
MsgBox myArray(0) 'Will open a message box with the value "One"
MsgBox myArray(1) 'Will open a message box with the value "Two"
MsgBox myArray(2) 'Will open a message box with the value "Three"
Whereas a standard array is one dimensional, using a Multidimensional Array allows you to add more than one dimension to this list. Put simply a two dimensional array will let you create a table of data.
dim myArray(1 to 3, 1 to 3) as Variant will create a two dimensional array, by also specifying '1 to 3' will allocate a set size and range of items that can be referenced in the array. Take for example this table:
A    B    C
D    E    F
G    H    I
To put this into a multidimensional array would be the following
Dim myArray(1 To 3, 1 To 3) As Variant
myArray(1, 1) = "A"
myArray(1, 2) = "B"
myArray(1, 3) = "C"
myArray(2, 1) = "D"
myArray(2, 2) = "E"
myArray(2, 3) = "F"
myArray(3, 1) = "G"
myArray(3, 2) = "H"
myArray(3, 3) = "I"
MsgBox myArray(2, 2) 'Will open a message box with the value "E"
Given you are looking to produce this from Range("A1:C4") you could use a loop to go through each cell create this:
Dim myArray(1 To 4, 1 To 3) As Variant
For Each c In Range("A1:C4")
myArray(c.Row, c.Column) = c.Value
Next c

Resources