在Excel VBA中复制唯一值 [英] Copy unique values in Excel VBA

问题描述

我编写了VBA代码，该代码将已过滤的表格从一个电子表格复制到另一个电子表格.这是代码:

I have written VBA code that copies a filtered table from one spreadsheet to another. This is the code:

Option Explicit

Public Sub LeadingRetailers()

Dim rngRows As Range

Set rngRows = Worksheets("StoreDatabase").Range("B5:N584")
With rngRows
    .SpecialCells(xlCellTypeVisible).Copy _
        Destination:=Worksheets("LeadingRetailersAUX").Range("B2")
End With

Sheets("Leading Retailers").Activate

End Sub

在运行代码之前应用过滤器，然后代码选择可见的单元格并将其复制，以便仅获取那些通过过滤器的行.

The filter is applied before the code is ran and then the code selects the visible cells and copies them so as to get only those rows that passed the filter.

在要复制的过滤表中，我在范围的L列中有一组特定名称，其中一些名称在几行中重复出现.

In the filtered table to be copied I have, in column L of the range, a certain set of names, some of which are repeated in several rows.

我想添加到代码中，以便它只为L列中的每个名称复制一行.换句话说，我希望代码仅复制出现在L列中的每个名称的第一行.过滤后的表格.

I would like to add to the code so that it only copies one row per name in column L. In other words, I would like the code to copy only the first row for each of the names that appears in Column L of the filtered table.

推荐答案

也许类似的东西可以为您提供帮助.代码将遍历您的行(5到584).首先，它检查行是否被隐藏.如果不是，将检查"L"列中的值是否已在字典中.如果不是，它将执行两件事:将行复制到目标表"，然后将值添加到字典".

Pehaps something like this can help you. Code will loop through your rows (5 to 584). First it checks if row is hidden. If not, will check if the value in column "L" is already in the Dictionary. If it is not, it will do two things: copy the row to Destination Sheet, and add the value to the Dictionary.

Option Explicit

Public Sub LeadingRetailers()
    Dim d As Object
    Dim i As Long
    Dim k As Long

    Set d = CreateObject("scripting.dictionary")
    i = 2 'first row of pasting (in "LeadingRetailersAUX")
    For k = 5 To 584
        If Not (Worksheets("StoreDatabase").Rows(k).RowHeight = 0) Then 'if not hidden
            If Not d.Exists(Worksheets("Hoja1").Cells(k, 12).Value) Then 'if not in Dictionary
                d.Add Worksheets("StoreDatabase").Cells(k, 12).Value, i 'Add it
                Worksheets("LeadingRetailersAUX").Cells(i, 2).EntireRow.Value = Worksheets("StoreDatabase").Cells(k, 1).EntireRow.Value
                i = i + 1
            End If
        End If
    Next

End Sub

这篇关于在Excel VBA中复制唯一值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！