问题描述
因此，我从工作表中获得了以下数据集：
+---------+-------------+-----------+
| 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
我似乎无法使其工作
解决方法
您没有回答我的澄清问题...
请测试下一个代码。它将处理范围内的尽可能多的值。它应该非常快，只能使用字典和数组在内存中工作。
代码需要添加对“ 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,2),arrM(i,3)
Else
dict(arrM(i,2)) = dict(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
传输数据
- 这不会复制标题，只会复制数据。
- 它不会复制提供的结果样本的第一列。
代码
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