Question

我想用不同的值复制整个列：string和integer。然后我想将单元格粘贴成一行，没有重复，例如你可以看到，我有一行没有重复。 column

暂时，我编写了这段代码，但是花了很多时间，因为我必须比较我的行的每个单元格，以便粘贴没有重复。 您是否知道复制整个列并将其连续排除而没有重复的功能？ 感谢

 Sub macro_finale()

Set codes_banques = Range("M35 :M57") ' je mets toute la colonne des codes banques dans la variable codes_banques
Dim code_courant As Integer ' cette variable va prendre chaque code un à un
Dim i As Integer
Dim compteur As Integer
Dim ligne_des_codes  As Integer ' TRES IMPORTANT = déclarer en tant qu'integer _
sinon quand on va comparer les cellules il comperera mal
Dim flag As Integer ' indicateur pour informer
flag = 0
compteur = 4


For Each cell In codes_banques

   '  MsgBox "voici le contenue de la colonne libellée " + cell.Value ' ligne test supprimable
    flag = 0 ' à la base le code banque n'est pas repertoriée
    If cell.Value <> "Code" Then ' IMPORTANT : si la cellule contient le mot code _
    on ne fait rien , on compare rien car c'est pas une code banque
    ' Remarque : c'est sensible à la casse, donc ne pas mettre code avec c miniscule
        code_courant = cell.Value



        For i = 4 To 6
            If Not Sheets("coller_ici").Cells(1, i).Value = Null Then
            ligne_des_codes = Sheets("coller_ici").Cells(1, i).Value
             End If
            MsgBox " voici code courant" & code_courant
             MsgBox " voici ligne des codes " & ligne_des_codes

             If code_courant = ligne_des_codes Then

                flag = 1 ' donc le code banque est déjà repértorié dans la feuille coller_ici _
                on ne va donc pas le rajouter dans la feuille coller_ici

            End If
        Next

       If flag = 0 Then ' donc le code banque n'est pas encore repértorié dans coller ici( dans la 1ere ligne )
       'on va donc l'ajouter
            Sheets("coller_ici").Cells(1, compteur).Value = code_courant
            compteur = compteur + 1
        End If
     End If
Next cell



End Sub

Answer 1

以下所有步骤本身都很简单，可以在SO上轻松找到。执行以下操作：

1）找到要复制的列中的最后一行

2）从列的第一行到最后一行定义范围

3）申请Range("yourRange).RemoveDuplicates Columns:=1, Header:=xlNo

4）再次找到最后一行

5）再次定义新范围

6）复制范围

7）申请Range("targetRange".PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=True

关于您尝试手动删除dublicates：

为了找到同意者，你做了将每个项目与每个项目进行比较的自然事物。其运行时间与O（n ^ 2）成比例。如果您首先对列表进行排序，则可以复制项目，跳过所有等号并转到下一个项目。 Sortng具有（最常见的）O（log（n）* n）和新选择唯一O（n）。因此，这种替代方案会更快。

Answer 2

此代码将采用 A 列中的常量，删除重复项并将结果粘贴到第1行，从单元格 B1 开始：

Sub JohnSmith()
    Dim r As Range

    Set r = Range("A:A").Cells.SpecialCells(2)
    r.RemoveDuplicates Columns:=1, Header:=xlNo
    r.Copy
    r(1).Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End Sub

在：

之后：

Answer 3

或者

Option Explicit
Sub Duplicates()

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        Dim rng As Range
        For Each rng In .Range("A1", .Cells(.Rows.count, 1).End(xlUp))'substitute your range here,  .Range("M20:M1000")?
            If Not dict.exists(rng.Value) And Not IsEmpty(rng) Then
                dict.Add rng.Value, rng.Value
            End If
        Next rng
        .Range("B1").Resize(1, dict.count) = dict.keys 'substitute your output cell here   Sheets("coller_ici").Cells(1, 4)?
    End With

End Sub

Answer 4

你可以尝试

Dim cell As Range
With CreateObject("Scripting.Dictionary")
    For Each cell In Range("M20:M1000").SpecialCells(xlCellTypeConstants)
        .Item(cell.Value) = 1
    Next
    Sheets("coller_ici").Cells(1, 4).Resize(, UBound(.Items) + 1).Value = .Keys
End With

如何复制列的所有单元格并将其粘贴到VBA

4 个答案: