excel - 在 VBA 的列中返回匹配项

Question

因此，我从工作表中获得了以下数据集：

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

我需要知道每个账户类型组合的价值。因此，我将帐户和类型复制到 B 列中的另一个工作表并连接帐户和类型。我删除了重复的之后

现在，我想像这样返回每个帐户的值并输入（在列中）。

+-----------+-----------+----------+-------------+----------+
| 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        |          |
+---------+-------------+------------------------+----------+

这是我的代码：

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

我似乎无法让它工作

Answer 1

你没有回答我的澄清问题...

请测试下一个代码。它将处理该范围内的尽可能多的值。它应该非常快，只在内存中工作，使用字典和数组。

该代码需要添加对“Microsoft Scripting Runtime”的引用（在 VBE: Tools->References...中，向下滚动直到找到上述引用，检查并按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

传输数据

• 这不会复制标题，只会复制数据。
• 它不会复制提供的结果样本的第一列。

编码

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