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

【问题标题】：how to copy all the cells of a column and paste it in a row without duplicates in VBA如何复制一列的所有单元格并将其粘贴到一行中而不在VBA中重复
【发布时间】：2018-09-17 23:59:59
【问题描述】：

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

【问题讨论】：

在您的网站上“您的代码图像没有帮助” 这不是代码。我认为您不必知道我的 cells.value 即可获得答案。那只是一个例子。而且已经有4个答案了
有答案，不代表不能提高问题的质量。链接中未包含的其他原因：现在每个人都必须单击两个链接才能了解问题。这是不必要的，不管是代码还是数据。我的建议：内联图像，最好从 Excel 文档中复制粘贴。这更具可读性，可以复制，实际上包括更少的步骤并且不受链接腐烂的影响。
当您有 1 个声誉时，您有义务添加与 imgur.com 的链接。我无法内联图像，因为我是新手。而且我不会复制粘贴 10000 行的范围。
在我看来，图像没有显示任何无法在 7 行格式良好的文本中显示的内容。你不能嵌入图像是unfortunately necessary, but has some nice side effects。让我们这样做，你看起来真的很投入（否则问题也很清楚），所以我会给你一个赞成票，这应该会给你必要的代表。嵌入图片并改进问题。
附录：请注意，Gary 的学生实际上确实努力将图像转录为他的答案，而您本可以将他从这些图像中拯救出来。

标签： vba excel duplicates copy-paste

【解决方案1】：

你可以试试

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

【讨论】：

@JohnSmith，有什么反馈吗？
非常好！只是一件小事：它是在复制一个空单元格，但这对我的工作并不重要！在法国网站上，我发现这条非常简单的线 Range("A1:A100").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("Feuil2").Range("A1"), Unique:=True 我想同时使用你的代码和这一行。但我不知道如何使用 CopyToRange 函数连续复制。谢谢
查看编辑后的答案以避免空白。如果它解决了您的问题，您可以考虑将答案标记为已接受，谢谢
据我所知，您不能使用AdvancedFilter() 转置

【解决方案2】：

以下所有步骤本身都很简单，可以在 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)。因此，这种替代方法会快得多。

【讨论】：

我的范围是 Range("M20:M1000") ，但是当我应用您的代码时，出现错误。错误 1004

【解决方案3】：

此代码将在列 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

之前：

之后：

【讨论】：

当我按 F8 以检查问题时，以下行 r.RemoveDuplicates Columns:=1, Header:=xlNo 出现错误。错误 1004：应用程序定义或对象定义错误
@JohnSmith 请注意，在我的演示代码中，数据位于 A 列中，由常量而非公式组成。您的数据在 M 列中
我知道 :D ，我在复制/粘贴到我的 excel 之前更改了它。我不会愚蠢地复制。我试过 range("M:M") 和 range("M20:M1000")

【解决方案4】：

或者

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

【讨论】：