Création automatique de ligne

Bonjour à toutes et tous,

J'ai besoin de vos Excellentes lumières ...

J'ai un fichier de 6 860 lignes sur 5 colonnes. Il s'agit d'une liste de noms (colonne A) et numéro de téléphone professionnel (colonne B), téléphone perso (colonne C) et portable (colonne D) et Référence en colonne(E).

Je souhaiterai faire une macro qui pour chaque nom en colonne A me créerai autant e ligne que de numéro de téléphone. je m'explique ...

DURAND | TEL 1 | TEL 2 | TEL 3 | 8000 deviendrai :

DURAND | Tel 1 | 800-1

DURAND | Tel 2 | 800-2

DURAND | Tel 3 | 800-3

DUPOND | TEL 1 | TEL 3 | 8012 deviendrai :

DUPOND | Tel 1 | 8012-1

DUPOND | Tel 3 | 8012-2

Merci d'avance de vos piste de réflexion car je me vois mal faire cela à la main pour la totalité du fichier.

A vous lire prochainement.

Jean

Bonjour,

pas compris comment Durant devient D upont

Bonjour,

Ta référence apparaît en E dans le premier cas, mais D dans le second ??

Chaque nom correspond à un enregistrent :

Chaque nom correspond à un enregistrement distinct DURAND restera toujours DURAND,

Pour la référence, elle doit rester en dernière position.

Ce fichier servira à enregistrer des numéro de téléphone direct et le système ne peut pas gérer plusieurs numéros sur une même ligne, il faut un et un seul numéro par ligne.

Si cela peut faciliter de laisser les numéros de téléphone sur la même colonne alors pas de problème.

Merci d'avance de vos réponses.

Pour la référence, elle doit rester en dernière position.

Cela ne dit pas s'il s'agit toujours de la colonne E... !

L'art de répondre aux questions...

Pour le moins confus

Bonsoir à tous,

Tes données à partir de A1, avec une ligne d'en-têtes

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long, k As Byte
    Application.ScreenUpdating = False
    a = Sheets(1).Range("a1").CurrentRegion.Value
    ReDim b(1 To (UBound(a, 1) - 1) * 3 + 1, 1 To 3)
    b(1, 1) = "Noms": b(1, 2) = "Tel": b(1, 3) = "Ref"
    n = 1
    For i = 2 To UBound(a, 1)
        For j = 2 To UBound(a, 2) - 1
            If a(i, j) <> "" Then
                n = n + 1: k = k + 1
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, j)
                b(n, 3) = a(i, 5) & "-" & k
            End If
        Next
        k = 0
    Next
    'Restitution en Feuil2
    With Sheets(2)
        .Cells.Clear
        With .Cells(1)
            .Resize(n, 3).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                '.Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Grand Grand merci à Klin89 pour cette macro qui marche parfaitement du premier coup et qui m'a permis de traiter mon fichier en moins d'une seconde.

Respect !

Merci aussi aux autres pour avoir pris du temps pour regarder ma requête.

En espérant pouvoir un jour vous rendre la pareille, bonne reprise à toutes et tous.

Jean