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

2
votes

I want to copy an entire column with differents values : string and integer. Then I want to paste the cells in a row, without duplicates for example as you can see, I have a row without duplicates. column

Column become row without duplicates

For the time being , I wrote this code , but it's take so much time , because I have to compare every cell of my row, in order to paste without duplicates. Do you know a function that copy an entire column and past it in a row without duplicates ? THanks

 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
4
vbaexcelduplicatescopy-paste
On your website 'An image of your code is not helpful' It's not a code. I don't think you have to know my cells.value for the answer. That was just an example. And there are already 4 answer – John Smith
Just because there are answers, doesnt mean you cannot improve the quality of the question. Additional reasons not included in the link: Right now everyone has to click two links to understand the problem. This is unnecessary, it doenst matter if it is code or data. My recommendation: inline the images, better copy paste from your excel document. This is more readable, can be copied, actually includes less steps for you and is not subject to link-rot. – leonardkraemer
It's an obligation when you have 1 reputation to add a link with imgur.com .I cannot inline the images, because I am a newfag. And I will not copy paste a range of 10000 lines. – John Smith
In my opinion the images do not show anything that can not be displayed within 7 lines of well formatted text. That you cant embed images is unfortunately necessary, but has some nice side effects. Lets do it this way, you seem really engaged (also the question otherwise is quite clear), so I'll give you an upvote, this should give you the necessary rep. to embed the pictures and improve the question. – leonardkraemer
Addendum: Notice that Gary's Student did in fact go through the effort to transcribe the images for his answer, which you could have saved him from. – leonardkraemer

4 Answers

0
votes

All the steps below are in itself easy and can be found on SO easily. Do the following:

1) Find the last row in the column that you want to copy

2) Define the Range from the first to the last row of the column

3) apply Range("yourRange).RemoveDuplicates Columns:=1, Header:=xlNo

4) Find the last row again

5) Define the new Range again

6) Copy Range

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

Regarding your try to remove dublicates manually:

To find the dublicates, you did the natural thing of comparing every item with every item. This has a running time proportional to O(n^2). If you sort the list first you can copy an item, skip all equals and go to the next item. Sortng has (most common) O(log(n)*n) and the new selecting uniques O(n). Therefore this alternative would be much faster.

0
votes

This code will take constants in column A, remove duplicates and paste the result in row #1 starting with cell 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

Before:

enter image description here

and after:

enter image description here

0
votes

Or

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
0
votes

you could try

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