Deplacer cellules

Bonjour,

Je fais énormément de recherches sur internet sur des annuaires.

Cela me donne des données en vrac que le copie dans excel.

Je recherche un macro pour déplacer des cellules si c'est un tel, un portable, une adresse, un code postal, une ville.

Je vous joint mon fichier.

J'ai mis une macro pour supprimer les lignes vides,

et une macro pour déplacer ( mais elle ne fonctionne pas)

Merci

bonjour,

une macro pour la mise en forme de tes feuilles 4 et 5

Sub misenformefeuille4et5()
j = 4 'feuil4
   ' f4 identifiant de la feuille sur laquelle on travaille
    Set f4 = Worksheets("Feuil" & j)
'dlf4 dernière ligne utilisée dans la feuille
    dlf4 = f4.Range("A" & Rows.Count).End(xlUp).Row
   ' ef numero de la fiche reconstituée
    ef = 0
' on parcourt toutes les lignes de la feuille
    For i = 1 To dlf4
 ' si la cellule est en grasse, il s'agit d'une nouvelle société
        If f4.Cells(i, 1).Font.Bold = True Then
            If adr <> "" Then f4.Cells(e, 4) = adr ' si il y  a une adresse pour la fiche précédente on l'écrit
            adr = ""
            sep = ""
            e = e + 1 ' on crée une nouvelle ficher
            f4.Cells(e, 2) = f4.Cells(i, 1) ' on copie le nom de la société
        ElseIf f4.Cells(i, 1) Like "## ## ## ## ##" Then ' sinon est-ce un numéro de téléphone
            f4.Cells(e, 3) = f4.Cells(i, 1) ' si oui on copie dans la colonne téléphone
        ElseIf f4.Cells(i, 1) <> "" Then ' sinon c'est une adresse ou une partie d'adresse
            adr = adr & sep & f4.Cells(i, 1) ' on colle les morceaux d'adresse les uns aux autres en le séparant par une nouvelle ligne
            If sep = "" Then sep = vbCrLf
        End If
    Next i
' on copi l'adresse de la dernière fiche
    f4.Cells(e, 4) = adr
End Sub

et pour la feuille 6

Sub misenformefeuill6()

j = 6 'feuil6

    Set f4 = Worksheets("Feuil" & j)
    dlf4 = f4.Range("A" & Rows.Count).End(xlUp).Row
    ef = 0
    For i = 1 To dlf4
 ' si la cellule est soulignée  c'est une nouvelle société
        If f4.Cells(i, 1).Font.Underline = xlUnderlineStyleSingle Then
            If adr <> "" Then f4.Cells(e, 4) = adr
            adr = ""
            sep = ""
            e = e + 1
            f4.Cells(e, 2) = f4.Cells(i, 1)
        ElseIf f4.Cells(i, 1) Like "## ## ## ## ##" Then
            f4.Cells(e, 3) = f4.Cells(i, 1)
        ElseIf f4.Cells(i, 1) <> "" Or f4.Cells(i, 1) = " " Then
            adr = adr & sep & f4.Cells(i, 1)
            If sep = "" Then sep = vbCrLf
        End If
    Next i
    f4.Cells(e, 4) = adr
End Sub

Bonjour h2so4,

Un grand merci très sincèrement.

J'ai testé .

Je n'ai plus qu'a comprendre et apprendre ton code.

Bonne journée

Merci

acymospc a écrit :

Bonjour h2so4,

Un grand merci très sincèrement.

J'ai testé .

Je n'ai plus qu'a comprendre et apprendre ton code.

Bonne journée

Merci

commentaires ajoutés dans le code fourni

Bonjour h2so4,

Oui j'ai vu par la suite

Merci