Returning matches in column in VBA

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

2 answers

  • answered 2020-10-16 08:08 FaneDuru

    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
    

  • answered 2020-10-16 09:42 VBasic2008

    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