Returning matches in column in VBA

Question

So I have the following data set from a worksheet:

+---------+-------------+-----------+
| Account | Type        |  Value    |
+---------+-------------+-----------+
| XX      | iPhone      | 123       |
| XX      | Samsung     | 567       |
| XX      | iPhone      | 222       |
| BB      | Samsung     | 999       |
| CC      | iPhone      | 998       |
+---------+-------------+-----------+

I needed to know the value for each account-type combination. So I copied account and type to another worksheet in column B and concatenated account and type. I removed the duplicated after

Now, I want to return the value for each account and type (in columns) like this.

+-----------+-----------+----------+-------------+----------+
| Account   | Account   |  Type     | Value 1    | Value 2  |
+-----------+-----------+---------+--------------+----------+
| XX-iPhone | XX        | iPhone    | 123        | 222      |
| XX-Samsung| XX        | Samsung   | 567        |          |
| BB-Samsung| BB        | Samsung   | 999        |          |
| CC-iPhone | CC        | iPhone    | 998        |          |
+---------+-------------+------------------------+----------+

Here's my code:

Dim Master as Worksheet, Filter as Worksheet
Dim lrow1 as Long

Set Master = Sheets("Master")
Set Filter = Sheets("Filter")

lrow1 = Master.range("A" & Rows.count).End(xlUp).row

Master.range("A2:B" & lrow1).copy
Filter.Range("B2").Pastespecial
'Copy info from Copy to Filter worksheet

Dim i as Integer, lrow2 as integer
lrow2 = Filter.Range("B" & Rows.count).End(xlUp).Row


With Filter
  For i = 2 to lrow2
    .Cells(i, 1) = .Cells(i ,2) & "-"& Cells(i, 3)
  Next
End With
'Concatenate data

Dim lrow3 As Long
lrow3 = Filter.range("A" & Rows.Count).End(xlUp).Row

Filter.Range("A2:C" & lrow3).RemoveDuplicates Columns:=Array(1), Header:=xlYes
'Remove Duplicates

Dim lrow4 as long
lrow4= Filter.Range("A" & Rows.Count).End(xlUp).row

Dim rg as range
Set rg = Filter.Range("A2:A" & lrow4)


Dim i as Integer, j as integer
i = 2
j = 3
   For Each cell in rg
     If cell = Master.Cells(i,1)& "-" & Master.Cells(i,2) Then
       cell.Offset(,j) = Master.Cells(i,3)
       i = i + 1
       j = j + 1
     End if
   Next

I can't seem to make it work

Answer 1

You did not answer my clarification question...

Please, test the next code. It will deal with as many values will be in the range. It should be very fast, working only in memory, using a dictionary and arrays.

The code needs adding a reference to "Microsoft Scripting Runtime" (being in VBE: Tools -> References..., scroll down until find the above reference, check it and press OK):

Sub testCopyArrange()
 Dim Master As Worksheet, Filter As Worksheet, lrow1 As Long, dict As New Scripting.Dictionary
 Dim arrM, arrFin, arrVal, i As Long, k As Long, El As Variant, arr, maxVal As Long

 Set Master = Sheets("Master")
 Set Filter = Sheets("Filter")
 lrow1 = Master.Range("A" & rows.count).End(xlUp).row

 arrM = Master.Range("A2:C" & lrow1).Value

 For i = 1 To UBound(arrM) 'load the data in dictionary
    If Not dict.Exists(arrM(i, 1) & " - " & arrM(i, 2)) Then
        dict.Add arrM(i, 1) & " - " & arrM(i, 2), arrM(i, 3)
    Else
        dict(arrM(i, 1) & " - " & arrM(i, 2)) = dict(arrM(i, 1) & " - " & arrM(i, 2)) & "|" & arrM(i, 3)
    End If
 Next i

 For Each El In dict.Items
    arr = Split(El, "|")
    If UBound(arr) > maxVal Then maxVal = UBound(arr)
 Next
 maxVal = maxVal + 1

 ReDim arrFin(1 To dict.count, 1 To 3 + maxVal)
 For i = 0 To dict.count - 1
    arr = Split(dict.Keys(i), " - ")
    arrFin(i + 1, 1) = dict.Keys(1): arrFin(i + 1, 2) = arr(0)
    arrFin(i + 1, 3) = arr(1)
    arrVal = Split(dict.Items(i), "|")
    For Each El In arrVal
        k = k + 1
        arrFin(i + 1, 3 + k) = El
    Next
    k = 0
 Next i
 Filter.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub

Answer 2

Transfer Data

• This will not copy the headers, only the data.
• It will not copy the first column of the resulting sample provided.

The Code

Option Explicit

Sub transferData()
    
    ' Initialize error handling.
    Const procName As String = "transferData"
    On Error GoTo clearError ' Turn on error trapping.

    ' Source
    Const srcName As String = "Master"
    Const srcFirst As String = "A2"
    Const NoC As Long = 3 ' Do not change.
    ' Target
    Const tgtName As String = "Filter"
    Const tgtFirst As String = "A2"
    ' Other
    Const Delimiter As String = "|"
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Define Source Range.
    Dim ws As Worksheet
    Set ws = wb.Worksheets(srcName)
    Dim rng As Range
    Set rng = ws.Cells(ws.Rows.Count, ws.Range(srcFirst).Column) _
                .End(xlUp).Offset(, NoC)
    Set rng = ws.Range(ws.Range(srcFirst), rng)
    Set ws = Nothing
    
    ' Write values from Source Range to Source Array.
    Dim Source As Variant
    Source = rng.Value
    Set rng = Nothing
    
    ' Write values from Source Array to Data Dictionary ('dict').
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    ' The Count Dictionary ('dictCount') is used just to calculate
    ' the number of Value Columns ('ValueColumns').
    Dim dictCount As Object
    Set dictCount = CreateObject("Scripting.Dictionary")
    Dim Key As Variant
    Dim ValueColumns As Long
    Dim i As Long
    For i = 1 To UBound(Source, 1)
        Key = Source(i, 1) & Delimiter & Source(i, 2)
        dict(Key) = dict(Key) & Delimiter & Source(i, 3)
        dictCount(Key) = dictCount(Key) + 1
        If dictCount(Key) > ValueColumns Then
            ValueColumns = dictCount(Key)
        End If
    Next i
    Set dictCount = Nothing
    Erase Source
        
    ' Write values from Data Dictionary to Target Array ('Target').
    Dim MainColumns As Long
    MainColumns = NoC - 1
    Dim Target As Variant
    ReDim Target(1 To dict.Count, 1 To MainColumns + ValueColumns)
    Dim Current As Variant
    Dim j As Long
    i = 0
    For Each Key In dict.Keys
        Current = Split(Key, Delimiter)
        i = i + 1
        Target(i, 1) = Current(0)
        Target(i, 2) = Current(1)
        Current = Split(dict(Key), Delimiter)
        For j = 1 To UBound(Current) ' 0, the first element will be "".
            Target(i, j + MainColumns) = Current(j)
        Next
    Next Key
    Set dict = Nothing
    
    ' Write values from Target Array to Target Range ('rng').
    Set ws = wb.Worksheets(tgtName)
    Set rng = ws.Range(tgtFirst).Resize(UBound(Target, 1), UBound(Target, 2))
    rng.Value = Target
    
    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"
    
ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & procName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit
    
End Sub