Si nombre d'occurence >1 alors concatener autre colonne

Pour enlever le tri, enlève la ligne :

    Columns("AR:AT").Sort Key1:=Range("AR4"), Order1:=xlAscending, Header:=xlGuess, _
                        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                        DataOption1:=xlSortNormal

Pour le code de claude :

naz4 a écrit :

Aves le code de Claude, j'obtiens une erreur 6 à la ligne:

Do While Cells(i + Cpt, 1) = Cells(i, 1)
                        Cells(i, 5) = Cells(i, 5) & "," & Cells(i + Cpt, 2)
                        Cpt = Cpt + 1 'L ERREUR EST ICI
                    Loop

Dans ton cas, c'est la variable Cpt qui est en cause. Pour y remédier, déclare tes variables comme ceci :

Dim Lg%, i%, Cpt%, x

% <=> Integer (valeur max : 32767) et si c'est pas assez, tu déclares tes variables en Long (valeur max : 2147483647) comme ceci :

Dim Lg&, i&, Cpt&, x

J'ai pas compris ça :

naz4 a écrit :

Et en plus il me modifie mon tableau dans une autre cellule au debut de mon fichier.

re,

Voilà ce qui arrive quand on a pas la structure réelle,

le demandeur n'arrive jamais à adapter !

Claude

Je vais surement vous sembler penible mais ayant supprimer le pb du triage, j'ai toujours le problème de la colonne des Véhicules inchangés avec le code de vbanews. Quelqu'un aurait-il une idée?

-- 21 Juil 2010, 14:22 --

dubois a écrit :

re,

Voilà ce qui arrive quand on a pas la structure réelle,

le demandeur n'arrive jamais à adapter !

Claude

Je ne sais pas comment faire autrement puisque ce sont des données confidentielles... Si vous avez une idée, je suis preneuse! (Je sens que je ne suis pas loin de bon but!) Merci de votre aide!

Claude a parfaitement raison.

Pourquoi ne pas joindre un bout de fichier en gardant la structure réelle de ce fichier ? Tu peux garder qu'une vingtaine de ligne si tu veux ! Tu peux aussi y mettre des données bidons manuellement !

Bonne idée j'envois ça tt de suite!

-- 21 Juil 2010, 14:55 --

Meme en ayant 10 lignes, je n'arrive pas à le compresser à moins de 300Ko...(le pb est que jai une 30 aines de colonnes et même en les vidant toutes, je n'arrive pas à faire moins...) Comment puis-je faire?

Bon bah essaie avec http://cjoint.com/ t'as droit à 1 Mo.

Merci je ne connaissais pas, voila le fichier écrémé avec la strucure (mais sans les macros que j'ai supprimé pr prendre moins de place),

Merci d'avance!

Waou ! Un fichier qui pèse 6 Mo avec seulement 2 feuilles !

Claude, si tu passes par là, j'ai essayé ta macro ménage sur son fichier mais pas moyen de descendre en-dessous de 6 Mo ! Ai-je mal fait la manip ?

Sinon, essaie avec ce code naz4 :

Sub concat2()
Dim newtblo As Object
Dim cel As Range, plage As Range
Dim i As Long, taillePlg As Long
Dim t As Single
Dim elt As String

    t = Timer
    Application.ScreenUpdating = False
    On Error Resume Next
    ActiveSheet.ShowAllData    'supprime le filtrage
    Range("ar4:ar" & [ar65536].End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete    'supprime les lignes dont la colonne A est vide
    On Error GoTo 0

    Set newtblo = CreateObject("Scripting.Dictionary")
    Set plage = Range("ar4:ar" & [ar65536].End(xlUp).Row)
    For Each cel In plage
        If Not newtblo.Exists(cel.Value) Then
            newtblo.Item(cel.Value) = cel.Offset(, 1).Value & "/"
        Else
            If Not (newtblo.Item(cel.Value) Like cel.Offset(, 1).Value & "/*" Or _
                    newtblo.Item(cel.Value) Like "*/" & cel.Offset(, 1).Value & "/*") Then
                newtblo.Item(cel.Value) = newtblo.Item(cel.Value) & cel.Offset(, 1).Value & "/"
            End If
        End If
    Next cel
    taillePlg = plage.Count
    ReDim tablo(1 To taillePlg, 0)
    For Each cel In plage
        elt = newtblo.Item(cel.Value)
        i = i + 1
        tablo(i, 0) = IIf(elt = "/", "", CStr(Mid(elt, 1, Len(elt) - 1)))
    Next cel
    [as4].Resize(taillePlg - 1, 1) = tablo
    Columns("as:as").NumberFormat = "@"
    MsgBox Timer - t & " s"

End Sub

Macro à lancer à partir de la feuille "feuil"

OOOHHH

Je ne sais pas comment vous le dire mais je vous adore!!!

Mille merci pour votre aide précieuse. Le dernier jet de vbanew est tombé pile poil!!

Je decouvre les forums et je trouve ça super (surtt ce forum que je conseille à tt le monde!)

MERCIII

Bonsoir à tous,

naz4,

Ne reste pas avec un fichier de 6 Mo , quelque chose le parasite,

d'ailleurs je n'ai pas réussi à l'ouvrir !

il vaudrait mieux recopier les données sur un nouveau fichier ?

vba-new,

Si le fichier est en 2003 et la macro "Ménage" inopérante, c'est que problème + sérieux ou autre,

Je dois revoir et adapter cette macro pour 2007

Amicalement

Claude

Re claude,

J'ai essayé d'enlever les listes de validation de la 2è feuille et la taille du fichier est tombée à 2 Mo et quelques. Ta macro détectait une cinquantaine d'objets mais en faisant Suppr, ça supprimait pas grand chose ! Il semblerait que les listes de validation soient aussi détectées comme des shapes !

Salut le forum

Vite fait en revenant du travail (5 secondes pour 7300 lignes)

Sub Essai()
Dim MonDico
Dim C As Range

Set MonDico = CreateObject("Scripting.Dictionary")

For Each C In Range("A2", [A65000].End(xlUp))
    If Not MonDico.Exists(C.Value) Then
        If Not IsEmpty(C.Value) Then MonDico(C.Value) = C.Offset(0, 1)
    Else
        If InStr(MonDico.Item(C.Value), C.Offset(0, 1)) = 0 Then
            MonDico(C.Value) = MonDico(C.Value) & "/" & C.Offset(0, 1)
        End If
    End If
Next C

For Each C In Range("A2", [A65000].End(xlUp))
    If MonDico.Exists(C.Value) Then C.Offset(0, 2) = MonDico(C.Value)
Next C

End Sub

Mytå

Bonjour forum,

Salut Mytå,

J'avais pensé au

If InStr(MonDico.Item(C.Value), C.Offset(0, 1)) = 0 Then

mais le problème est que si un des codes véhicules est égal à 161 par exemple, et un autre égal à 61, la condition

If InStr("161", "61") = 0 Then

n'est pas vérifiée alors que 61 n'existe pas dans le MonDico.Item(C.Value).

C'est pourquoi, n'ayant rien trouvé de mieux, j'avais proposé :

            If Not (newtblo.Item(cel.Value) Like cel.Offset(, 1).Value & "/*" Or _
                    newtblo.Item(cel.Value) Like "*/" & cel.Offset(, 1).Value & "/*") Then

dubois a écrit :

Bonsoir à tous,

naz4,

Ne reste pas avec un fichier de 6 Mo , quelque chose le parasite,

d'ailleurs je n'ai pas réussi à l'ouvrir !

il vaudrait mieux recopier les données sur un nouveau fichier ?

vba-new,

Si le fichier est en 2003 et la macro "Ménage" inopérante, c'est que problème + sérieux ou autre,

Je dois revoir et adapter cette macro pour 2007

Amicalement

Claude

Merci Claude pour tes conseils

vba-new a écrit :

Re claude,

J'ai essayé d'enlever les listes de validation de la 2è feuille et la taille du fichier est tombée à 2 Mo et quelques. Ta macro détectait une cinquantaine d'objets mais en faisant Suppr, ça supprimait pas grand chose ! Il semblerait que les listes de validation soient aussi détectées comme des shapes !

Je n'ai pas compris ce qu'est les lignes de validation dans mon fichier? et des shapes?

naz4 a écrit :

Je n'ai pas compris ce qu'est les lignes de validation dans mon fichier?

naz4 a écrit :

et des shapes?

Ok merci! Vous allez me rendre une véritable accro au forum d'excel (et dire qu'il y a 2 semaines je ne savais même pas ce qu'étais un filtre!!)

Merci à tous!

Bonjour à tous,

Autre petit conseil,

à la création d'un nouveau fichier, surveille régulièrement son poids,

si tu vois qu'il gonfle anormalement => STOP et analyse le pourquoi.

Pour info:

500 Ko, c'est déjà un beau fichier, 1 Mo c'est un très gros fichier,

au delà tu dois te poser des questions et revoir l'ensemble du projet.

Amicalement

Claude.

Bonjour vbanews,

je me permets de te contacter à propos d'une ancienne discussion. je ne me le permettra pas si ce n'était pas très important. Mais j'essai de mettre à jour mes données, donc j'ai éffectué la macro que tu m'as donné et les références que j'ai changé gardent le même code véhicule. En d'autre terme, je n'arrive pas à comprendre pourquoi elle ne donne pas de résultat . C'est la première fois que j'essai de la faire fonctionner avec des nouvelles valeurs de références. Peux-tu m'aider?

Je t'en serait extrêment reconnaissante.

Merci d'avance

Bonjour naz4,

Peux-tu joindre ton fichier ?