Mise en forme d'un tableau....(transposition)

Bonjour,

j'ai un tableau de plus de 10.000 lignes sur une seule colonne.

Ce sont des adresses du style :

Mr trucmuche

entreprise xyxyxy

trucmuche@xyxyxy.com

chemin de la route

bp 1452

bat 1

03200 machinchose

entreprise transport

transport@transport.fr

route du chemin

03152 chosemachin

je dois mettre cela en ligne et dans plusieurs colonnes qui se suivent en sachant où mettre la donnée.Par exemple adresse dans colonne adresse, email dans email, tel dans tel....etc...la transposition ne fonctionne pas car toute les adresses n'ont pas le même nombre de lignes. Parfois je n'ai pas le nom du contact, parfois l'adresse est plus courte...

donc je me suis dis que j'allais faire un test sur le CP puisque tous les contacts sont dans le même département.

mais je galère depuis 3 jours complets sans trouver comment faire.

j'ai testé aussi la fonction décaler, les si les ou mais je galère...

Merci de votre aide !

Bruno.

Bonjour,

Un petit fichier représentatif serait un plus pour t'aider

Cdlt.

bonjour,

voici un extrait du fichier. Dans la colonne C, le test que je fais sur le code postal.

Merci.

Bonsoir,

Un essai (si ton modèle est bien représentatif de l'ensemble de tes données) :

Sub ReclassContact()
    Dim ctct(), rsd, adr, tst, m%, n%, h%, i%, j%, k%
    tst = Split("Nom;Raison sociale;Désignation;Tél.;e-mail;site;Compl. adr.;Adresse;CP Ville", ";")
    ReDim ctct(8, 0)
    For i = 0 To 8
        ctct(i, 0) = tst(i)
    Next i
    tst = Split(";M.*;Mme*;Tél*;*@*;www*", ";")
    h = 1
    With Worksheets("Feuil1")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 1 To n
            If .Cells(i, 1).Value Like "06###*" Then
                k = k + 1
                ReDim Preserve ctct(8, k)
                ctct(8, k) = .Cells(i, 1).Value
                For j = h To i - 1
                    For m = 1 To 5
                        If .Cells(j, 1).Value Like tst(m) Then Exit For
                    Next m
                    Select Case m
                        Case 1, 2
                            ctct(0, k) = .Cells(j, 1).Value
                        Case 3 To 5
                            ctct(m, k) = .Cells(j, 1).Value
                            tst(0) = 1
                        Case Else
                            If tst(0) = 1 Then
                                adr = adr & "!" & .Cells(j, 1).Value
                            Else
                                rsd = rsd & "!" & .Cells(j, 1).Value
                            End If
                    End Select
                Next j
                rsd = Split(rsd, "!")
                ctct(1, k) = rsd(1)
                If UBound(rsd) > 1 Then ctct(2, k) = rsd(2)
                adr = Split(adr, "!")
                If UBound(adr) = 1 Then
                    ctct(7, k) = adr(1)
                Else
                    ctct(6, k) = adr(1)
                    ctct(7, k) = adr(2)
                End If
                rsd = "": adr = "": tst(0) = 0: h = i + 1
            End If
        Next i
    End With
    For i = 1 To k
        ctct(3, i) = Right(ctct(3, i), Len(ctct(3, i)) - 6)
    Next i
    With Worksheets("Feuil2")
        Range(.Cells(1, 1), .Cells(k + 1, 9)) = Application.Transpose(ctct)
        .Columns("A:I").AutoFit
        With .Range("A1:I1")
            .Font.Italic = True
            .HorizontalAlignment = xlCenter
        End With
    End With
End Sub

Cordialement

Ferrand