时间戳

首页 > 解决方案 > 将表加载到数组中并合并所有重复项 - Excel VBA

arrays - 将表加载到数组中并合并所有重复项 - Excel VBA

问题描述

我有许多需要合并数据的表。我已经将一些表组合成一个测试表来测试代码。在运行我的代码之前，我正在对列“B”az 中的唯一值进行排序。只有约 3500 条记录，速度非常慢。实际总数超过 100,000 条记录。我很想知道是否可以将整个表加载到数组中并执行相同的功能，但我不确定是否可能。

我的表结构是：

唯一身份 第一的 最后的 公司 等等
A1 约翰
A1 能源部
A1 公司1
A2 周杰伦 瓦尔纳多
A3 乔 鼻烟
A3 M。 公司2

期望的结果是：

唯一身份 第一的 最后的 公司 等等
A1 约翰 能源部 公司1
A1 约翰 能源部 公司1
A1 约翰 能源部 公司1
A2 周杰伦 瓦尔纳多
A3 乔·M。 鼻烟 公司2
A3 乔·M。 鼻烟 公司2 
Dim cel As Range, rng As Range, r As Range
Dim arr(14) As String, temp As String
Dim i As Long, b As Long, j As Long, lRow As Long, lRec As Long, c As Long
Dim ii As Integer, v As Integer, col As Integer
Dim dict As Scripting.Dictionary
Dim str() As String
Dim BenchMark As Double

BenchMark = Timer

lRow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
For c = 3 To lRow
    Debug.Print c
    Set cel = Sheet3.Range("B" & c)
    
    If Trim(cel.Offset(1, 0)) = Trim(cel.Value) Then
    
    'Determine range of like keys
        i = 1
        Do Until cel.Offset(i, 0).Value <> cel.Value
            i = i + 1
        Loop
        
        lRec = cel.Offset(i, 0).Row - 1
    
    'Compare data
        For i = 3 To 16
            ii = i - 3
            
        'Create rng and loop through each column
            Set rng = Sheet3.Range(Sheet3.Cells(c, i), Sheet3.Cells(lRec, i))
            Set dict = New Scripting.Dictionary 'CreateObject("Scripting.Dictionary")
            
            For Each r In rng
                If dict.Exists(r.Value) = False And Len(r.Value) > 0 Then
                    dict.Add r.Value, r.Value
                End If
            Next r
            
            
        'Add to string array
            'Debug.Print Split(Join(dict.Keys, "|"), "|")
            str = Split(Join(dict.Keys, ","), ",")
            arr(ii) = Join(str, ",")
            Set dict = Nothing
        Next i
            
    'Set range equal to array
        For j = cel.Row To lRec
            v = 0
            
            For col = 3 To 16
                Sheet3.Cells(j, col) = arr(v)
                Sheet3.Cells(j, col) = arr(v)
                v = v + 1
            Next col
        
        Next j
'Go to last cell in range
    c = lRec
    Else: GoTo NextCel
    End If
        
'Clear array
NextCel:
    On Error Resume Next
        'Debug.Print Join(arr, ",")
        Erase arr
    On Error GoTo 0
Next c

MsgBox ("Done in " & Timer - BenchMark)

End Sub

标签： arraysexcelvba

解决方案

假设 ID 在 B 列中，并作为每个 ID 的单行输出到 Sheet1 或与 Sheet2 重复。

Option Explicit

Sub Process()
    
    Dim dict As Object, key
    Dim iLastRow As Long, n As Long, r As Long
    Dim c As Integer, s As String
    Dim arIn, arOut, t0 As Single: t0 = Timer

    Set dict = CreateObject("Scripting.Dictionary")

    iLastRow = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
    arIn = Sheet3.Range("A1").Resize(iLastRow, 16).Value2
    n = 0
    ' determine number of unique ids
    For r = 3 To iLastRow
        key = Trim(arIn(r, 2))
        If Len(key) > 0 Then
            If Not dict.exists(key) Then
                n = n + 1
                dict.Add key, n
             End If
        End If
    Next

    ' dimension output array and fill
    ReDim arOut(1 To n, 1 To 15)
    For r = 3 To iLastRow
        key = Trim(arIn(r, 2))
        n = dict(key)
        arOut(n, 1) = key
        ' concat columns
        For c = 3 To 16
            s = Trim(arIn(r, c))
            If Len(s) > 0 Then
                arOut(n, c - 1) = arOut(n, c - 1) & " " & s
            End If
        Next
    Next

    ' output to sheet1
    Sheet1.Range("A1").Resize(n, 15) = arOut
    MsgBox "Done in " & Format(Timer - t0, "0.0 secs")

    ' or with duplicates to sheet2
   For r = 3 To iLastRow
        key = Trim(arIn(r, 2))
        n = dict(key)
        Sheet2.Cells(r, 2) = key
        For c = 3 To 16
            Sheet2.Cells(r, c) = arOut(n, c - 1)
        Next
    Next
    
End Sub

推荐阅读