Fusionner lignes doublons

Bonjour,

Peut-être que je ne cherche pas avec les bons mots clefs, mais je ne trouve pas de solution à mon "problème", d'où mon post.

Mon iPhone a la sale manie de créer des contacts en double quand je fais une sauvegarde iTune. Je me retrouve avec deux fiches pour M. Untel : une fiche contient l'adresse email, une autre le téléphone (ou le portable et le fixe, etc.)

J'ai donc fait une sauvegarde de ma base contacts sous Excel, et maintenant je cherche le moyen de fusionner ces lignes en double autrement qu'à la main (1500 lignes !!)

Existe-t-il un moyen de dire à Excel :

Si le contenu de la colonne NOM est identique, fusionner le contenu des autres cellules

OU :

créer une nouvelle ligne prenant pour chaque colonne le contenu non vide des lignes doublonnées

Ce n'est pas très facile d'expliquer ce que j'essaie de faire, donc je joins un petit exemple.

Merci 1000 fois pour votre aide, car je repousse depuis longtemps ce travail, mais là je n'ai plus le choix, il faut que je m'y mette : lors de la dernière sauvegarde iTunes, mon iPhone a carrément vidé le contenu de mes fiches contacts !!! Il me reste les noms, mais presque plus aucun numéro de téléphone ni adresse... et la même chose s'est produite, pendant la synchronisation, dans mon Outlook ;( Heureusement, il me reste des sauvegardes Excel, mais pleines de lignes en double voire triple ;(

Bonjour,

un essai à tester.

Cordialement.

Bonjour,

Sub RegroupeLigneS()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("BD")
  Set f2 = Sheets("résultats")
  ncol = f1.[a1].CurrentRegion.Columns.Count
  nlig = f1.[a1].CurrentRegion.Rows.Count
  d1.CompareMode = vbTextCompare
  For ligne = 1 To nlig
    crit = f1.Cells(ligne, 1) & f1.Cells(ligne, 2)
    d1(crit) = ""
    ligT = Application.Match(crit, d1.keys, 0)
    For col = 1 To ncol
      If f1.Cells(ligne, col) <> "" Then f2.Cells(ligT, col) = f1.Cells(ligne, col).Text
    Next col
    If f1.Cells(ligne, ncol) <> "" Then f1.Cells(ligne, ncol).Copy f2.Cells(ligT, ncol)
  Next ligne
End Sub

Merci beaucoup mais... ça ne fonctionne pas correctement.

ceci dit, j'ai peut-être vraiment trop simplifié le modèle que j'ai envoyé ?

Dans la réalité, une sauvegarde de contacts iPhone sous Excel a des colonnes qui vont de A à... CB !! Est-ce que ça peut venir de ça ?

Toujours est-il que la macro mélange les adresses email (et sans doute d'autres données).

Ne pouvant, comme tu peux le comprendre, pas t'envoyer mon vrai fichier, je ne sais pas trop comment faire pour mieux me faire comprendre.

De quoi aurais-tu besoin ?

Florence

Je ne vois pas les erreurs

http://boisgontierjacques.free.fr/fichiers/Cellules/FusionLignesDoublons.xls

Sur l'exemple fourni, le email (dernière colonne) a un traitement particulier (copié pour récupérer un hypelien)

Envoyer un fichier avec 3 lignes .

Ceuzin

D'accord, je t'envoie un extrait de ma base, avec les répétitions les plus flagrantes. Et avec des homonymes ayant des prénoms différents, pour voir.

Merci beaucoup pour ton aide !

EDIT : j'ai oublié ! les adresses email sont a priori dépourvues de tout lien hypertexte dans la sauvegarde. J'utilise une application iPhone qui s'appelle ContactsKit, et c'est cette application qui génère ce tableur (en .xls). Il ne contient aucun lien hypertexte, j'imagine que quand on restaure les contacts, l'iPhone sait les interpréter comme ça.

Bonjour,

En prenant le nom comme clé:

Sub RegroupeLigneS()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("BD")
  Set f2 = Sheets("résultats")
  ncol = f1.[a1].CurrentRegion.Columns.Count
  nlig = f1.[a1].CurrentRegion.Rows.Count
  d1.CompareMode = vbTextCompare
  For ligne = 1 To nlig
    crit = sansAccent(f1.Cells(ligne, "d"))  ' nom
    d1(crit) = ""
    ligT = Application.Match(crit, d1.keys, 0)
    For col = 1 To ncol
      If f1.Cells(ligne, col) <> "" Then f2.Cells(ligT, col) = f1.Cells(ligne, col).Text
    Next col
    'If f1.Cells(ligne, ncol) <> "" Then f1.Cells(ligne, ncol).Copy f2.Cells(ligT, ncol)
  Next ligne
End Sub

Function sansAccent(chaine)
   codeA = "ÉÈÊËÔéèêëàçùôûïî"
   codeB = "EEEEOeeeeacuouii"
   temp = chaine
   For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
   Next
   sansAccent = temp
End Function

En prenant le nom+prénom comme clé (voir pj)

Ceuzin

filtre
Rechercher des sujets similaires à "fusionner lignes doublons"