Question

业余编码器在这里，我试图编写一个Excel-VBA代码，可以使用来自数据转储的更新信息自动更新行（原始数据来自先前的转储，只是想保留excel sheet更新数据转储，并保持用户输入数据与数据转储数据一致）。代码应该比较每行前4列中的值，以获得相同列上整个工作表中的重复数据，如果找到具有相同数据的重复行，则它将使用新数据{{3}替换原始行因此，在此示例中，代码将替换第1行：将EFG列替换为第8行的EFG列，因为它们已全部更改，但保留所有用户输入数据和更新的数据。第5行FG也是如此，替换为第11行，FG列。等等。然后根据A-D列中的重复数据删除所有重复的行。我在Excel-VBA中编写了一些非常基本的代码，但这个代码远远超出了我的能力，因此我甚至不知道从哪里开始。任何建议或简单的起点都会有所帮助！

Answer 1

我最近在Excel VBA中查找重复项时进行了一些测试。这是关于StackOverflow的一个常见问题，答案范围从笨重到精致，使用各种方法。

我担心OP没有提供足够的信息来回答他/她的具体问题，但显然他/她需要编写例程来管理重复项。所以我希望下面的代码会有所帮助。

测试涉及获取500,000个项目的数据集，将唯一值写入新工作表并将这些值存储在array或Collection中。我使用5种不同的方法记录了处理任务的时间：Range.AdvancedFilter，Collection，数组比较，Range.RemoveDuplicates和Application.Match。这些项目仅存储在一列中，并且是具有500个唯一值的字符串（因此没有日期会使事情变得更加尴尬）。按速度顺序的结果是：

AdvancedFilter，0.19秒
收集，1.83秒
RemoveDuplicates，2.41秒
阵列比较，37.28秒
比赛，38.75秒

AdvancedFilter

优点：

非常快，肯定是删除重复项的最佳方式。

缺点：

要求输出到Range（因此可能需要隐藏的工作表）
包括标题（因此需要对结果进行一些管理）
没有进一步编码就无法识别一个项目与另一个项目匹配的位置（因此，如果您尝试找到匹配值，它将无法工作，因为此OP将会是这样）。

集合

优点：

所有包含在VBA中（如果您未将结果写入worksheet
相当快
标识匹配项（例如，值，匹配项目的索引等）
使您能够在与唯一值关联的集合中存储其他数据（例如，重复发生的次数，其他行值等）。

缺点：

需要String作为唯一键，（因此可能需要进行某些转换，如果密钥最初是Integer或Long，则会发生错误而您忘记转换它到String进行查询）
需要捕获错误才能找到重复内容，而某些开发人员并不喜欢这样的哲学（Dictionary对象会绕过这一点）。

RemoveDuplicates

优点：

如果您只想删除现有Range
无需在别处输出结果
标题没有问题
仍然可敬的速度

缺点：

与AdvancedFilter一样，没有进一步编码就无法识别匹配。

数组比较

优点：

适合VBA的初学者，因为代码易于理解和编写。
识别匹配并保持唯一项目的运行计数
与Collections一样，将所有内容保留在VBA中。

缺点：

痛苦地缓慢（但如果对数据进行排序，还有相当大的速度提升范围）
更难写入Worksheet，因为结果数组是一维的，因此管理行可能是个问题。如果只有VBA允许ReDim第一维......

匹配

优点：

如果你只想找一场比赛
识别匹配

缺点：

如果您有大型数据集，请打开水壶
效率低下的代码（但跳过已知重复项的改进会非常有帮助）

所以，我认为在管理重复项时很难看过AdvancedFilters和Collections，但是没有人的宝贝是丑陋的，所以请你选择。

如果您对此感兴趣，测试代码如下：

Option Explicit
Private mTimer As clsTimer
Private mDataRanges As Collection
Private Const ADV_FILTER_KEY As String = "AdvancedFilter"
Private Const COLLECTION_KEY As String = "Collection"
Private Const ARRAY_COMP_KEY As String = "Array Comparison"
Private Const REMOVE_DUPES_KEY As String = "RemoveDuplicates"
Private Const MATCH_KEY As String = "Match"

Public Sub RunMe()
    Dim srcSht As Worksheet
    Dim outSht As Worksheet
    Dim lastCell As Range
    Dim loc As clsRanges

    'Initialise
    Set mTimer = New clsTimer

    'Idenfity the source data
    Set srcSht = ThisWorkbook.Worksheets("SourceData")
    Set outSht = ThisWorkbook.Worksheets("UniqueList")
    Set lastCell = srcSht.Cells(srcSht.Rows.count, "A").End(xlUp)

    'Prepare the output sheet
    outSht.Cells.Clear
    outSht.Cells(1, 1).Value = "Type"
    outSht.Cells(2, 1).Value = "Secs"


    'Define the source and output ranges
    Set mDataRanges = New Collection

    Set loc = New clsRanges
    loc.Create lastCell, outSht, 2, True
    mDataRanges.Add loc, ADV_FILTER_KEY

    Set loc = New clsRanges
    loc.Create lastCell, outSht, 3
    mDataRanges.Add loc, COLLECTION_KEY

    Set loc = New clsRanges
    loc.Create lastCell, outSht, 4
    mDataRanges.Add loc, ARRAY_COMP_KEY

    Set loc = New clsRanges
    loc.Create lastCell, outSht, 5
    mDataRanges.Add loc, REMOVE_DUPES_KEY

    Set loc = New clsRanges
    loc.Create lastCell, outSht, 6
    mDataRanges.Add loc, MATCH_KEY

    'Find the unique values using different methods
    UsingAdvFilter
    UsingCollection
    UsingArrayComparison
    UsingRemoveDuplicates
    UsingMatch

End Sub
Private Sub UsingAdvFilter()
    Dim loc As clsRanges
    Dim v As Variant
    Dim rng As Variant
    Dim srcRange As Range
    Dim outRange As Range

    'Start the clock
    mTimer.StartCounter

    'Run the filter to write unique values
    Set loc = mDataRanges(ADV_FILTER_KEY)
    loc.SourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=loc.OutputRange, unique:=True

    'Read the unique values into an array
    v = loc.OutputRange.CurrentRegion.Resize(, 1).Value

    'Stop the clock
    loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)

    'Write the heading
    loc.OutputRange.Offset(-2).Value = ADV_FILTER_KEY
    loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingCollection()
    Dim col As Collection
    Dim data As Variant
    Dim key As String
    Dim item As Variant
    Dim v() As Variant
    Dim i As Long
    Dim loc As clsRanges

    'Start the clock
    mTimer.StartCounter

    'Read the source data into an array
    Set loc = mDataRanges(COLLECTION_KEY)
    data = loc.SourceRange.Value2


    'Prepare error handler to trap duplicate keys
    On Error Resume Next

    'Loop through the data array to find unique values
    Set col = New Collection
    For i = 1 To UBound(data, 1)

        'Define the key (must be a String)
        key = CStr(data(i, 1))

        'Test if collection already contains the key
        'If it doesn't an error 5 will be thrown
        item = col(key)
        If Err.Number = 5 Then 'key doesn't exist
            col.Add data(i, 1), key
            Err.Clear
        ElseIf Err.Number <> 0 Then 'trap any unplanned errors
            MsgBox Err.Description
            End
        End If

    Next

    'Restore the error handler
    On Error GoTo 0

    'Read the unique values into an array
    ReDim v(1 To col.count, 1 To 1)
    i = 1
    For Each item In col
        v(i, 1) = item
        i = i + 1
    Next

    'Write the unique values
    loc.OutputRange.Resize(UBound(v, 1)).Value = v

    'Stop the clock
    loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)

    'Write the heading
    loc.OutputRange.Offset(-2).Value = COLLECTION_KEY
    loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingArrayComparison()
    Dim loc As clsRanges
    Dim data As Variant
    Dim tmp() As Variant
    Dim v() As Variant
    Dim i As Long
    Dim c As Long
    Dim count As Long
    Dim isUnique As Boolean

    'Start the clock
    mTimer.StartCounter

    'Read the source data into an array
    Set loc = mDataRanges(ARRAY_COMP_KEY)
    data = loc.SourceRange.Value2

    'Dimension the array which will temporarily store unique values
    ReDim tmp(1 To UBound(data, 1))

    'Set the unique counter - use 0 to prevent the loop running on first item.
    count = 0

    'Loop through the data array
    For i = 1 To UBound(data, 1)

        'Test if value is already contained in unique list
        'by iterating through it until a match is found
        isUnique = True
        For c = 1 To count
            If data(i, 1) = tmp(c) Then
                isUnique = False
                Exit For
            End If
        Next

        'If no match is found then add it to the temporary array
        'and increment the count
        If isUnique Then
            count = count + 1
            tmp(count) = data(i, 1)
        End If

    Next

    'Trim the temporary array to the unique count size
    ReDim Preserve tmp(1 To count)

    'Unfortunately we can't write a one-dimensional array to
    'a Worksheet (without using some form of Transposition)
    'so we'll copy it to a two-dimensional one.
    'It would be easier if we could just Dim the tmp array
    'in two dimensions, but ReDim only allows us to adjust the
    'last dimension (ie column), so we can't deal with rows.
    ReDim v(1 To count, 1 To 1)
    For i = 1 To count
        v(i, 1) = tmp(i)
    Next

    'Write the unique values
    loc.OutputRange.Resize(count).Value = v

    'Stop the clock
    loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)

    'Write the heading
    loc.OutputRange.Offset(-2).Value = ARRAY_COMP_KEY
    loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingRemoveDuplicates()
    Dim loc As clsRanges
    Dim rng As Range
    Dim v As Variant
    Dim count As Long

    'Start the clock
    mTimer.StartCounter

    'Resize the output range to match the source data range
    Set loc = mDataRanges(REMOVE_DUPES_KEY)
    Set rng = loc.OutputRange.Resize(loc.SourceRange.Rows.count)

    'Turn off screen updating to keep our test fair
    Application.ScreenUpdating = False

    'Write the full source data to the output sheet
    rng.Value = loc.SourceRange.Value2

    'Run the remove duplicates routine
    rng.RemoveDuplicates 1, xlNo

    'Restore screen updating
    Application.ScreenUpdating = True

    'Calculate size of range without the duplicates
    count = rng.Cells(rng.Rows.count, 1).End(xlUp).Row - loc.OutputRange.Row + 1

    'Read the values into an array
    v = loc.OutputRange.Resize(count).Value

    'Stop the clock
    loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)

    'Write the heading
    loc.OutputRange.Offset(-2).Value = REMOVE_DUPES_KEY
    loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingMatch()
    Dim data As Variant
    Dim lastPos As Long
    Dim searchRange As Range
    Dim isUnique As Boolean
    Dim loc As clsRanges
    Dim count As Long
    Dim i As Long
    Dim tmp() As Variant
    Dim v() As Variant


    'Start the clock
    mTimer.StartCounter

    'Read the source data into an array
    Set loc = mDataRanges(MATCH_KEY)
    data = loc.SourceRange.Value2

    'Dimension the array which will temporarily store unique values
    ReDim tmp(1 To UBound(data, 1))

    'Prepare the loop parameters
    lastPos = UBound(data, 1)
    count = 0

    For i = 1 To lastPos

        If i = lastPos Then 'no need to look for a match as it's the last one
            isUnique = True
        Else
            'Define the search range to be one below the current item to the end.
            Set searchRange = loc.SourceRange.Cells(i + 1, 1).Resize(lastPos - i)
            isUnique = IsError(Application.Match(data(i, 1), searchRange, 0))
        End If

        'If there's no match, add the item to our uniques array
        If isUnique Then
            count = count + 1
            tmp(count) = data(i, 1)
        End If

    Next

    'Trim the temporary array to the unique count size
    ReDim Preserve tmp(1 To count)

    'Same one-dimensional array issue as array method so transpose.
    ReDim v(1 To count, 1 To 1)
    For i = 1 To count
        v(i, 1) = tmp(i)
    Next

    'Write the unique values
    loc.OutputRange.Resize(count).Value = v

    'Stop the clock
    loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)

    'Write the heading
    loc.OutputRange.Offset(-2).Value = MATCH_KEY
    loc.OutputRange.EntireColumn.AutoFit
End Sub

...为了完整起见，这里是clsRanges代码：

Private mSrcRange As Range
Private mOutRange As Range
Public Sub Create(srcLastCell As Range, outSht As Worksheet, outCol As Long, Optional incHeader As Boolean = False)
    Dim ws As Worksheet
    Dim r As Long
    Dim c As Long

    Set ws = srcLastCell.Worksheet
    r = IIf(incHeader, 1, 2)
    c = srcLastCell.Column
    Set mSrcRange = ws.Range(ws.Cells(r, c), srcLastCell)
    Set mOutRange = outSht.Cells(3, outCol)

End Sub
Public Property Get SourceRange() As Range
    Set SourceRange = mSrcRange
End Property
Public Property Get OutputRange() As Range
    Set OutputRange = mOutRange
End Property

如何编写Excel-VBA代码来更新包含从程序导出的数据的Excel工作表？

1 个答案:

AdvancedFilter

集合

RemoveDuplicates

数组比较

匹配