Déplacer le contenu de cellules

[JORDAN]

Bonjour tout le monde, le Forum,

Je souhaite déplacer automatiquement le contenu de certaines cellules qui se situe dans la colonne D vers soit les colonnes A, B ou C. Je ne sais pas comment m'y prendre, par la taille de caractère, le contenu d'autres cellules, ...

Je vous joints mon fichier qui j'espère sera assez explicite, j'ai ajouté des couleurs pour une meilleure visualisation et créé une feuille avec le résultat souhaité

Par avance merci pour votre aide et vos conseils
Cdt

 

[JORDAN]

Re : Déplacer le contenu de cellules

Re,

C'est bon, j'ai réussi, peut être pas avec du vba tres pur mais ça fonctionne
Cdt

 

[pierrejean]

Re : Déplacer le contenu de cellules

Bonjour JORDAN

Vois si cela te convient

 

[mapomme]

Re : Déplacer le contenu de cellules

message annulé

 

[mapomme]

Re : Déplacer le contenu de cellules

Bonjour JORDAN, pierrejean

Un essai basé sur les cellules vides de la colonne E.

Edit: version avec marquage 'sans porc'

 

[JORDAN]

Re : Déplacer le contenu de cellules

Bonsoir Pierrejean, Mapomme,

Merci pour vos fichiers qui une fois adaptés à mon fichier complet (1500 lignes) fonctionnent beaucoup plus vite que le mien !!!
Très pratique la version sans porc
Merci beaucoup à tous les deux
Cdt

Sub deplace()
Dim i

For i = 2 To 10000
    If Cells(i, 8).Font.Size = 12 Then Cells(i, 8).Font.Size = 14
Next i

For i = 2 To 1500
    If Cells(i, 8).Font.Size = 10 Then
        If Cells(i, 14) = "" Then
            Cells(i, 8).Font.Size = 12
        End If
    End If
Next i

For i = 2 To 1500
    If Cells(i, 8).Font.Size = 18 Then Cells(i, 1) = Cells(i, 8)
    If Cells(i, 8).Font.Size = 14 Then Cells(i, 2) = Cells(i, 8)
    If Cells(i, 8).Font.Size = 12 Then Cells(i, 3) = Cells(i, 8)
Next i

For i = 3 To 1500
    If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1)
    If Cells(i, 2) = "" Then Cells(i, 2) = Cells(i - 1, 2)
    If Cells(i, 3) = "" Then Cells(i, 3) = Cells(i - 1, 3)
Next i

For i = Range("E65536").End(xlUp).Row To 2 Step -1
    If Cells(i, 5) = "" Then Cells(i, 5).EntireRow.Delete
Next i

End Sub