如何复制一列的所有单元格并将其粘贴到一行中而不重复 VBA

Question

我想复制具有不同值的整个列：字符串和整数。然后我想连续粘贴单元格，没有重复，例如，如您所见，我有一行没有重复。 column

Column become row without duplicates

目前，我编写了这段代码，但它花费了很多时间，因为我必须比较行中的每个单元格，以便粘贴时不重复。 你知道一个函数可以复制整列并连续传递它而不重复吗？ 谢谢

 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) 再次定义新的Range

6) 复制范围

7) 应用Range("targetRange".PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=True

关于您尝试手动删除重复项：

为了找到重复项，您自然而然地将每一项与每一项进行了比较。这具有与 O(n^2) 成正比的运行时间。如果您首先对列表进行排序，则可以复制一个项目，跳过所有相等项并转到下一个项目。 Sortng 具有（最常见的）O(log(n)*n) 和新的选择唯一性 O(n)。因此，这种替代方案会快得多。

Answer 2

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

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

how to copy all the cells of a column and paste it in a row without duplicates in VBA

excel

vba

copy-paste

duplicates