I am trying to iterate through an array using:-
For i = LBound(arr, 1) To UBound(arr, 1)
Debug.Print arr(i, 1)
Next i
but receive a Subscript out of range error at Debug.Print arr(i, 1) which I do not understand. The code works fine if I take out the above lines.
Sub Summarise()
Dim dict
Dim i As Long
Dim arr() As Variant
Dim n As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws2 = Worksheets("Plan")
Set ws = Worksheets("Data")
dict = ws.[A1].CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(dict, 1)
.Item(dict(i, 1)) = .Item(dict(i, 1)) + dict(i, 5)
Next
arr = Array(.Keys, .items)
n = .Count
End With
For i = LBound(arr, 1) To UBound(arr, 1)
Debug.Print arr(i, 1)
Next i
ws2.[A1].CurrentRegion.ClearContents
ws2.[A1].Resize(n, 2).Value = Application.Transpose(arr)
End Sub
Your line arr = Array(.Keys, .items) is creating an array of arrays and not an array of those items.
i.e. Array(Array(1,2,3), Array(4,5,6))
To loop through this you would need to do something like
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr(i)) to UBound(arr(i))
Debug.Print arr(i)(j)
Next j
Next i
To avoid doing this and loop through as you're currently you could add to your array as you add to your dictionary
Related
Anyone have any idea why i am getting a subscript out of range error at the IF statement. I am just learning arrays so i can only assume it has to do with that.
Dim CARMA2 As Worksheet
Dim Assignments As Worksheet
Sub data2()
Dim arr() As Variant
Dim CAR() As Variant
arr = Array(Worksheets("Assignments").UsedRange)
CAR = Array(Worksheets("CARMA2").UsedRange)
Dim i As Variant
For x = LBound(CAR, 1) To UBound(CAR, 1)
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 5) = CAR(x, 1) And arr(i, 7) = """" Then
arr(i, 7) = CAR(x, 3)
End If
Next i
Next x
End Sub
To put all the values from a range into a 2-d array, assign the Value property of the range to a Variant, like
Dim arr As Variant
arr = Worksheets("Assignments").UsedRange.Value
You can use Dim arr() as Variant, but it's unnecessary. It's just coercing every element of the array to a Variant. But Dim arr As Variant will create a variant array (not an array of variants) and the elements will be typed as appropriate.
When you create this kind of array, it's base 1 array. So your 3, 5, and 7 need to account for that.
Sub data2()
Dim arr As Variant
Dim CAR As Variant
Dim x As Long, i As Long
arr = Worksheets("Assignments").UsedRange.Value
CAR = Worksheets("CARMA2").UsedRange.Value
For x = LBound(CAR, 1) To UBound(CAR, 1)
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 5) = CAR(x, 1) And arr(i, 7) = """" Then
arr(i, 7) = CAR(x, 3)
End If
Next i
Next x
End Sub
I am populating a array with values from part of a column (range). The resulting array is multidimensional - but it should be one dimensional. I want to get just Emp ID values into the array:
I have tried this :
Sub Test()
Dim colPostionNumber As Integer
Dim lastRow As Integer
Dim ws As Worksheet
Dim positionNumberArray As Variant
Set ws = ActiveSheet
With ActiveWorkbook.Sheets("Sheet 1")
colPositionNumber = Application.WorksheetFunction.Match("Emp ID", ws.Rows(5), 0)
lastRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).row
positionNumberArray = .Range(Cells(5, colPositionNumber), Cells(lastRow, colPositionNumber)).Value
End With
End Sub
But the resulting array is two dimensional
I tried reDim but that didn't work. How do I do this with a one dimensional array?
Write One-Column 2D Array to 1D Array
To get a zero-based 1D array, you will have to loop.
Sub Test()
Dim colPositionNumber As Long
Dim lastRow As Long
Dim ws As Worksheet
Dim Data As Variant
Dim positionNumberArray As Variant
Set ws = ActiveSheet
With ActiveWorkbook.Sheets("Sheet 1")
colPositionNumber = Application.Match("Emp ID", ws.Rows(5), 0)
lastRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Data = .Range(.Cells(5, colPositionNumber), _
.Cells(lastRow, colPositionNumber)).Value
ReDim positionNumberArray(UBound(Data, 1) - 1)
Dim n As Long
For n = 1 To UBound(Data, 1)
positionNumberArray(n - 1) = Data(n, 1)
Next n
End With
End Sub
Using Application.Transpose
The following procedures show how to write a one-column or a one-row range to a one-based 1D array:
Sub testATColumn()
Dim rg As Range: Set rg = Range("A1:A5")
Dim arr As Variant: arr = Application.Transpose(rg.Value)
Debug.Print LBound(arr, 1), UBound(arr, 1)
On Error Resume Next
Debug.Print LBound(arr, 2), UBound(arr, 2)
On Error GoTo 0
End Sub
Sub testATRow()
Dim rg As Range: Set rg = Range("A1:E1")
Dim arr As Variant
arr = Application.Transpose(Application.Transpose(rg.Value))
Debug.Print LBound(arr, 1), UBound(arr, 1)
On Error Resume Next
Debug.Print LBound(arr, 2), UBound(arr, 2)
On Error GoTo 0
End Sub
Note that Application.Transpose has a limit of 65535 elements per dimension.
Reduce dimension via Excel function ArrayToText()
If you dispose of version MS 365 you could try the following approach via Excel function ArrayToText() and an eventual split action.
Sub reduceDim()
Dim t#: t = Timer
Dim rng As Range
Set rng = Sheet1.Range("B2:B7") ' << change to your needs
Dim data
data = Split(Evaluate("ArrayToText(" & rng.Address(False, False, External:=True) & ")"), ", ")
Debug.Print "Array(" & LBound(data) & " To " & UBound(data) & ")"
Debug.Print Join(data, "|") ' display resulting 0-based 1-dim array elements
Debug.Print Format(Timer - t, "0.00 secs")
End Sub
Output in VB Editor's immediate window
Array(0 To 5)
1|2|3|4|5|6
0,00 secs
I have an Excel Sheet where some rows may contain the same data as other rows. I need a macro to sum all the values in that column and delete all the duplicates rows, except for the first one, which contains the sum of the rest.
I have tried multiple versions of code and the code that produces the results closest to what I need looks like this, but this code contains one problem is: infinite loop.
Sub delet()
Dim b As Integer
Dim y As Worksheet
Dim j As Double
Dim k As Double
Set y = ThisWorkbook.Worksheets("Sheet1")
b = y.Cells(Rows.Count, 2).End(xlUp).Row
For j = 1 To b
For k = j + 1 To b
If Cells(j, 2).Value = Cells(k, 2).Value Then
Cells(j, 3).Value = (Cells(j, 3).Value + Cells(k, 3).Value)
Rows(k).EntireRow.Delete
k = k - 1
ElseIf Cells(j, 2).Value <> Cells(k, 2).Value Then
k = k
End If
Next
Next
End Sub
I would recommend getting the data in an array and then do the relevant operation. This is a small range and it may not affect the performance but for a larger dataset it will matter.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim MyAr As Variant, outputAr As Variant
Dim col As New Collection
Dim itm As Variant
Dim totQty As Double
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row of col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Get those value in an array
MyAr = .Range("A2:C" & lRow).Value2
'~~> Get unique collection of Fam.
For i = LBound(MyAr) To UBound(MyAr)
If Len(Trim(MyAr(i, 2))) <> 0 Then
On Error Resume Next
col.Add MyAr(i, 2), CStr(MyAr(i, 2))
On Error GoTo 0
End If
Next i
'~~> Prepare array for output
ReDim outputAr(1 To col.Count, 1 To 3)
i = 1
For Each itm In col
'~~> Get Product
For j = LBound(MyAr) To UBound(MyAr)
If MyAr(i, 2) = itm Then
outputAr(i, 1) = MyAr(i, 1)
Exit For
End If
Next j
'~~> Fam.
outputAr(i, 2) = itm
totQty = 0
'~~> Qty
For j = LBound(MyAr) To UBound(MyAr)
If MyAr(j, 2) = itm Then
totQty = totQty + Val(MyAr(j, 3))
End If
Next j
outputAr(i, 3) = totQty
i = i + 1
Next itm
'~~> Copy headers
.Range("A1:C1").Copy .Range("G1")
'~~> Write array to relevant range
.Range("G2").Resize(UBound(outputAr), 3).Value = outputAr
End With
End Sub
Output
If VBA isn't essential and you've got 365:
In cell G2 enter the formula =UNIQUE(A2:B11)
In cell I2 enter the formula =SUMIFS(C2:C11,A2:A11,INDEX(G2#,,1),B2:B11,INDEX(G2#,,2))
Remove Duplicates with Sum
Adjust the values in the constants section.
Note that if you choose the same worksheets and "A1", you will overwrite.
The Code
Option Explicit
Sub removeDupesSum()
Const sName As String = "Sheet1"
Const dName As String = "Sheet1"
Const dFirst As String = "G1"
Dim wb As Workbook: Set wb = ThisWorkbook
' Write values from Source Range to Data Array.
Dim Data As Variant
Data = wb.Worksheets(sName).Cells(1).CurrentRegion.Value
' Write unique values from Data Array to Unique Sum Dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim arr As Variant: ReDim arr(2 To UBound(Data, 1)) ' for first column
Dim n As Long: n = 1
Dim i As Long
For i = 2 To UBound(Data, 1)
If dict.Exists(Data(i, 2)) Then
dict(Data(i, 2)) = dict(Data(i, 2)) + Data(i, 3)
Else
n = n + 1
arr(n) = Data(i, 1)
dict(Data(i, 2)) = Data(i, 3)
End If
Next i
Dim Result As Variant: ReDim Result(1 To dict.Count + 1, 1 To 3)
' Write headers.
For i = 1 To 3
Result(1, i) = Data(1, i)
Next i
Erase Data
' Write 'body'.
Dim Key As Variant
i = 1
For Each Key In dict.Keys
i = i + 1
Result(i, 1) = arr(i)
Result(i, 2) = Key
Result(i, 3) = dict(Key)
Next Key
' Write values from Result Array to Destination Range.
With wb.Worksheets(dName).Range(dFirst).Resize(, 3)
.Resize(i).Value = Result
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
Dim pos As Range, range1 As Range, range2 As Range
Dim x As Variant, Y As Variant
Set pos = Sheets("Sheet1").Cells(5, 6)
For Each y In range1
Set pos = pos.Offset(3, 0) 'Currently setting 3 spaces between each change of Y
For Each x In range2
If y = x Then
x.Cells(, 5).Copy pos
Set pos = pos.Offset(1, 0)
End If
Next x
Next y
Instead of putting spaces of 3, I want to know how many times X is copied for each time that Y changes, how would you do this?
I was thinking a counter, but how would you reset it?
Counting Using an Array or a Dictionary
All solutions are case-insensitive, i.e. A=a.
These are 3 pairs of solutions where each first is using a second loop, while each second is using Application.CountIf as a more efficient way instead.
The second pair (solutions 3 and 4) should be the most efficient, but can only be used if the values in range1 are unique, while the others can be used in any case, the first pair (solutions 1 and 2) probably being more efficient.
Also consider the differences between retrieving the values from the array and retrieving the values from the dictionary.
The Code
Option Explicit
Sub testUniqueDictionaryLoop()
Dim range1 As Range: Set range1 = Range("D2:D11")
Dim range2 As Range: Set range2 = Range("F2:H11")
Dim y As Range
Dim x As Range
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
For Each y In range1.Cells
If Not dict.Exists(y.Value) Then
dict(y.Value) = 0
For Each x In range2.Cells
If StrComp(x.Value, y.Value, vbTextCompare) = 0 Then
dict(y.Value) = dict(y.Value) + 1
End If
Next x
End If
Next y
' Write to the Immediate window.
Dim Key As Variant
For Each Key In dict.keys
Debug.Print Key, dict(Key)
Next Key
' Write to a two-column range.
With Range("A2").Resize(, 2)
.Resize(Rows.Count - .Row + 1).ClearContents
.Columns(1).Resize(dict.Count).Value = Application.Transpose(dict.keys)
.Columns(2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
End With
End Sub
Sub testUniqueDictionaryCountIf()
Dim range1 As Range: Set range1 = Range("D2:D11")
Dim range2 As Range: Set range2 = Range("F2:H11")
Dim y As Range
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
For Each y In range1.Cells
If Not dict.Exists(y.Value) Then
dict(y.Value) = Application.CountIf(range2, y.Value)
End If
Next y
' Write to the Immediate window.
Dim Key As Variant
For Each Key In dict.keys
Debug.Print Key, dict(Key)
Next Key
' Write to a two-column range.
With Range("A2").Resize(, 2)
.Resize(Rows.Count - .Row + 1).ClearContents
.Columns(1).Resize(dict.Count).Value = Application.Transpose(dict.keys)
.Columns(2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
End With
End Sub
Sub testArrayLoop()
Dim range1 As Range: Set range1 = Range("D2:D11")
Dim range2 As Range: Set range2 = Range("F2:H11")
Dim y As Range
Dim x As Range
Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
Dim i As Long
For Each y In range1.Cells
i = i + 1
Data(i, 1) = y.Value
Data(i, 2) = 0
For Each x In range2.Cells
If StrComp(x.Value, y.Value, vbTextCompare) = 0 Then
Data(i, 2) = Data(i, 2) + 1
End If
Next x
Next y
' Write to the Immediate window.
For i = 1 To UBound(Data, 1)
Debug.Print Data(i, 1), Data(i, 2)
Next i
' Write to a two-column range.
With Range("A2").Resize(, 2)
.Resize(Rows.Count - .Row + 1).ClearContents
.Resize(UBound(Data, 1)).Value = Data
End With
End Sub
Sub testArrayCountIf()
Dim range1 As Range: Set range1 = Range("D2:D11")
Dim range2 As Range: Set range2 = Range("F2:H11")
Dim y As Range
Dim x As Range
Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
Dim i As Long
For Each y In range1.Cells
i = i + 1
Data(i, 1) = y.Value
Data(i, 2) = Application.CountIf(range2, Data(i, 1))
Next y
' Write to the Immediate window.
For i = 1 To UBound(Data, 1)
Debug.Print Data(i, 1), Data(i, 2)
Next i
' Write to a two-column range.
With Range("A2").Resize(, 2)
.Resize(Rows.Count - .Row + 1).ClearContents
.Resize(UBound(Data, 1)).Value = Data
End With
End Sub
Sub testUniqueArrayLoop()
Dim range1 As Range: Set range1 = Range("D2:D11")
Dim range2 As Range: Set range2 = Range("F2:H11")
Dim y As Range
Dim x As Range
Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
Dim i As Long
For Each y In range1.Cells
If IsError(Application.Match(y.Value, Data, 0)) Then
i = i + 1
Data(i, 1) = y.Value
Data(i, 2) = 0
For Each x In range2.Cells
If StrComp(x.Value, y.Value, vbTextCompare) = 0 Then
Data(i, 2) = Data(i, 2) + 1
End If
Next x
End If
Next y
Dim k As Long: k = i
' Write to the Immediate window.
For i = 1 To k
Debug.Print Data(i, 1), Data(i, 2)
Next i
' Write to a two-column range.
With Range("A2").Resize(, 2)
.Resize(Rows.Count - .Row + 1).ClearContents
.Resize(k).Value = Data
End With
End Sub
Sub testUniqueArrayCountIf()
Dim range1 As Range: Set range1 = Range("D2:D11")
Dim range2 As Range: Set range2 = Range("F2:H11")
Dim y As Range
Dim x As Range
Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
Dim i As Long
For Each y In range1.Cells
If IsError(Application.Match(y.Value, Data, 0)) Then
i = i + 1
Data(i, 1) = y.Value
Data(i, 2) = Application.CountIf(range2, Data(i, 1))
End If
Next y
Dim k As Long: k = i
' Write to the Immediate window.
For i = 1 To k
Debug.Print Data(i, 1), Data(i, 2)
Next i
' Write to a two-column range.
With Range("A2").Resize(, 2)
.Resize(Rows.Count - .Row + 1).ClearContents
.Resize(k).Value = Data
End With
End Sub
I made a collection object that will add a new counter for every y. In the second loop it increments the last element of the collection by one. At the end if you look at each element in the collection it should contain the number of times x=y per y element.
Dim pos As Range
Dim range1 As Range
Dim range2 As Range
Dim x As Range
Dim y As Range
Dim countXinY As New Collection
Set pos = Sheets("Sheet1").Cells(5, 6)
For Each y In range1
countXinY.Add 0
Set pos = pos.Offset(3, 0) 'Currently setting 3 spaces between each change of Y
For Each x In range2
If y = x Then
countXinY(countXinY.Count) = countXinY(countXinY.Count) + 1
x.Cells(, 5).Copy pos
Set pos = pos.Offset(1, 0)
End If
Next x
Next y
I have a list of lists in Excel. There is some specifications (name, age, country, etc) in the first column and values in the second column. I don't want to repeat the same specifications over and over again. What I want to show in the picture. I tried =VLOOKUP() but it did not work perfectly because the lists do not include the same specifications. How can I achieve this?
A VBA macro can generate the results, and also the list of parameters for the first column of results.
To enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
Be sure to set the Reference as stated in the Note in the macro
To use this Macro (Sub), alt-F8 opens the macro dialog box. Select the macro by name, and RUN.
This macro generates the list with the parameter list in the first column. It could be easily rewritten to have the parameter list in the first row, if that is preferable.
Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub GroupLists()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim dictParams As Dictionary
Dim sParam As String
Dim I As Long, J As Long, K As Long
Dim V As Variant
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 5)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
End With
'Get unique list of Parameters with row number
'Also count the number of entries for number of columns in final result
J = 0
Set dictParams = New Dictionary
K = 0 'row number for parameter
For I = 1 To UBound(vSrc, 1)
J = J + 1 'column count
Do
If Not dictParams.Exists(vSrc(I, 1)) Then
K = K + 1
dictParams.Add Key:=vSrc(I, 1), Item:=K
End If
I = I + 1
If I > UBound(vSrc) Then Exit Do
Loop Until vSrc(I, 1) = ""
If I > UBound(vSrc) Then Exit For
Next I
'Create results array
ReDim vRes(1 To dictParams.Count, 1 To J + 1)
'Populate Column 1
For Each V In dictParams.Keys
vRes(dictParams(V), 1) = V
Next V
'Populate the data
J = 1 'column number
For I = 1 To UBound(vSrc, 1)
J = J + 1
Do
sParam = vSrc(I, 1)
vRes(dictParams(sParam), J) = vSrc(I, 2)
I = I + 1
If I > UBound(vSrc) Then Exit Do
Loop Until vSrc(I, 1) = ""
If I > UBound(vSrc) Then Exit For
Next I
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes
End Sub
EDIT: Macro modified to reflect the "real data"
Please note: You will need to add a second worksheet for the results. I named it "Sheet2"
Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub GroupLists()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim dictParams As Dictionary
Dim sParam As String
Dim I As Long, J As Long, K As Long
Dim V As Variant
Dim sDelim As String 'Differentiates each record
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
sDelim = vSrc(1, 1)
End With
'Get unique list of Parameters with row number
'Also count the number of entries for number of columns in final result
J = 0
Set dictParams = New Dictionary
K = 0 'row number for parameter
For I = 1 To UBound(vSrc, 1)
J = J + 1 'column count
Do
If Not dictParams.Exists(vSrc(I, 1)) Then
K = K + 1
dictParams.Add Key:=vSrc(I, 1), Item:=K
End If
I = I + 1
If I > UBound(vSrc) Then Exit Do
Loop Until vSrc(I, 1) = sDelim
If I > UBound(vSrc) Then
Exit For
Else
I = I - 1
End If
Next I
'Create results array
ReDim vRes(1 To dictParams.Count, 1 To J + 1)
'Populate Column 1
For Each V In dictParams.Keys
vRes(dictParams(V), 1) = V
Next V
'Populate the data
J = 1 'column number
For I = 1 To UBound(vSrc, 1)
J = J + 1
Do
sParam = vSrc(I, 1)
vRes(dictParams(sParam), J) = vSrc(I, 2)
I = I + 1
If I > UBound(vSrc) Then Exit Do
Loop Until vSrc(I, 1) = sDelim
If I > UBound(vSrc) Then
Exit For
Else
I = I - 1
End If
Next I
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes
End Sub
EDIT2: This macro is a modification of the above, which lists the results in the opposite orientation. It may be more useful.
Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub GroupListsVertical()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim dictParams As Dictionary
Dim sParam As String
Dim I As Long, J As Long, K As Long
Dim V As Variant
Dim sDelim As String 'Differentiates each record
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet3")
Set rRes = wsRes.Cells(1, 1)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
sDelim = vSrc(1, 1)
End With
'Get unique list of Parameters with row number
'Also count the number of entries for number of columns in final result
J = 0
Set dictParams = New Dictionary
K = 0 'column number for parameter
For I = 1 To UBound(vSrc, 1)
J = J + 1 'row count
Do
If Not dictParams.Exists(vSrc(I, 1)) Then
K = K + 1
dictParams.Add Key:=vSrc(I, 1), Item:=K
End If
I = I + 1
If I > UBound(vSrc) Then Exit Do
Loop Until vSrc(I, 1) = sDelim
If I > UBound(vSrc) Then
Exit For
Else
I = I - 1
End If
Next I
'Create results array
ReDim vRes(1 To J + 1, 1 To dictParams.Count)
'Populate row 1
For Each V In dictParams.Keys
vRes(1, dictParams(V)) = V
Next V
'Populate the data
J = 1 'row number
For I = 1 To UBound(vSrc, 1)
J = J + 1
Do
sParam = vSrc(I, 1)
vRes(J, dictParams(sParam)) = vSrc(I, 2)
I = I + 1
If I > UBound(vSrc) Then Exit Do
Loop Until vSrc(I, 1) = sDelim
If I > UBound(vSrc) Then
Exit For
Else
I = I - 1
End If
Next I
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes
rRes.EntireColumn.AutoFit
End Sub
Use following ARRAY formulas.
Cell F2 formula
=IFERROR(INDEX($B$1:$B$20,SMALL(IF($A$1:$A$20=$E2,ROW($B$1:$B$20),""),COLUMN(A:A))),"")
Cell E19 formula
=IFERROR(INDEX($B$1:$B$20,SMALL(IF($A$1:$A$20=$E2,ROW($B$1:$B$20),""),COLUMN(A:A))),"")
Press CTRL+SHIFT+ENTER to evaluate the formula as it is an array formula.