返回 VBA 列中的匹配项
Returning matches in column in VBA
所以我从工作表中获得了以下数据集：
+---------+-------------+-----------+
| Account | Type | Value |
+---------+-------------+-----------+
| XX | iPhone | 123 |
| XX | Samsung | 567 |
| XX | iPhone | 222 |
| BB | Samsung | 999 |
| CC | iPhone | 998 |
+---------+-------------+-----------+
我需要知道每个帐户类型组合的价值。所以我将帐户和类型复制到 B 列中的另一个工作表并连接帐户和类型。我在
之后删除了重复的
现在，我想 return 每个帐户的值并像这样输入（在列中）。
+-----------+-----------+----------+-------------+----------+
| 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
我似乎无法让它工作
你没有回答我的澄清问题...
请测试下一个代码。它将处理范围内的尽可能多的值。它应该非常快，只在内存中工作，使用字典和数组。
代码需要添加对“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
传输数据
- 这不会复制 headers，只会复制数据。
- 它不会复制提供的结果示例的第一列。
代码
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
所以我从工作表中获得了以下数据集：
+---------+-------------+-----------+
| Account | Type | Value |
+---------+-------------+-----------+
| XX | iPhone | 123 |
| XX | Samsung | 567 |
| XX | iPhone | 222 |
| BB | Samsung | 999 |
| CC | iPhone | 998 |
+---------+-------------+-----------+
我需要知道每个帐户类型组合的价值。所以我将帐户和类型复制到 B 列中的另一个工作表并连接帐户和类型。我在
之后删除了重复的现在，我想 return 每个帐户的值并像这样输入（在列中）。
+-----------+-----------+----------+-------------+----------+
| 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
我似乎无法让它工作
你没有回答我的澄清问题...
请测试下一个代码。它将处理范围内的尽可能多的值。它应该非常快，只在内存中工作，使用字典和数组。
代码需要添加对“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
传输数据
- 这不会复制 headers，只会复制数据。
- 它不会复制提供的结果示例的第一列。
代码
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