Microsoft 365 Remplacer cellule par d'autres en macro

saggigo

XLDnaute Occasionnel
Bonjour à tous chère communauté,
Voila j'ai une feuille excel et je souhaite ajouter un bouton qui permet de mettre une valeur d'une cellule X si la première cellule est vite

donc pour faire plus dans le détail, j'ai mis un fichier excel test en pièce jointe, et j'aimerais que mon bouton test :
- Si les valeurs en colonne D sont différentes de "" alors remplacer le contenu de la colonne A par D juste pour les cellules non vides
- Si les valeurs en colonne E et G sont vides, prendre les valeurs respectives des colonnes M et N et les mettre dans E et G.

Merci beaucoup pour votre aide :):):)
 

Pièces jointes

  • TEST.xlsx
    11 KB · Affichages: 4

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Saggigo,
Essayez :
VB:
Sub Remplace()
    Application.ScreenUpdating = False: Dim L%
    For L = 2 To Range("C65500").End(xlUp).Row  ' Jusqu'à dernire ligne de C
        ' Si D non vide et A vide alors A=D
        If Cells(L, "D") <> "" And Cells(L, "A") = "" Then Cells(L, "A") = Cells(L, "D")
        ' Si M non vide et E vide alors E=M
        If Cells(L, "M") <> "" And Cells(L, "E") = "" Then Cells(L, "E") = Cells(L, "M")
        ' Si N non vide et G vide alors G=N
        If Cells(L, "N") <> "" And Cells(L, "G") = "" Then Cells(L, "G") = Cells(L, "N")
    Next L
    Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • TEST (12).xlsm
    17.8 KB · Affichages: 4

Dranreb

XLDnaute Barbatruc
Bonjour.
En supposant qu'après transfert les cellules source doivent être effacées pour ne pas rester identiques en deux places désignées différemment, je l'écrirais comme ça :
VB:
Sub Actualiser()
   Dim Rng As Range, T(), L As Long
   Set Rng = Feuil1.UsedRange
   Set Rng = Rng.Rows(2).Resize(Rng.Rows.Count - 1)
   T = Rng.Value
   For L = 1 To UBound(T, 1)
      If T(L, 4) <> "" Then
         T(L, 1) = T(L, 4)
         T(L, 4) = Empty
         End If
      If IsEmpty(T(L, 5)) And IsEmpty(T(L, 7)) Then
         T(L, 5) = T(L, 13)
         T(L, 7) = T(L, 14)
         T(L, 13) = Empty: T(L, 14) = Empty
         End If
      Next L
   Rng.Value = T
   End Sub
 

saggigo

XLDnaute Occasionnel
Bonjour Saggigo,
Essayez :
VB:
Sub Remplace()
    Application.ScreenUpdating = False: Dim L%
    For L = 2 To Range("C65500").End(xlUp).Row  ' Jusqu'à dernire ligne de C
        ' Si D non vide et A vide alors A=D
        If Cells(L, "D") <> "" And Cells(L, "A") = "" Then Cells(L, "A") = Cells(L, "D")
        ' Si M non vide et E vide alors E=M
        If Cells(L, "M") <> "" And Cells(L, "E") = "" Then Cells(L, "E") = Cells(L, "M")
        ' Si N non vide et G vide alors G=N
        If Cells(L, "N") <> "" And Cells(L, "G") = "" Then Cells(L, "G") = Cells(L, "N")
    Next L
    Application.ScreenUpdating = True
End Sub
Bonjour Sylvanu,
Je te remercie pour le support, j'aime bien ton code qui est très explicite, peux-tu s'il te plait quel code ajouter pour vider les cellule copiées? j'aimerais vider: D; M; N

Merci beaucoup :)
 

saggigo

XLDnaute Occasionnel
Bonjour.
En supposant qu'après transfert les cellules source doivent être effacées pour ne pas rester identiques en deux places désignées différemment, je l'écrirais comme ça :
VB:
Sub Actualiser()
   Dim Rng As Range, T(), L As Long
   Set Rng = Feuil1.UsedRange
   Set Rng = Rng.Rows(2).Resize(Rng.Rows.Count - 1)
   T = Rng.Value
   For L = 1 To UBound(T, 1)
      If T(L, 4) <> "" Then
         T(L, 1) = T(L, 4)
         T(L, 4) = Empty
         End If
      If IsEmpty(T(L, 5)) And IsEmpty(T(L, 7)) Then
         T(L, 5) = T(L, 13)
         T(L, 7) = T(L, 14)
         T(L, 13) = Empty: T(L, 14) = Empty
         End If
      Next L
   Rng.Value = T
   End Sub
Bonjour Dranreb,
Je te remercie pour ton support, mais j'ai pas su comment l'adapter si je veux changer de colonne.

Merci encore
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir,
VB:
Sub Remplace()
    Application.ScreenUpdating = False: Dim L%
    For L = 2 To Range("C65500").End(xlUp).Row  ' Jusqu'à dernire ligne de C
        ' Si D non vide et A vide alors A=D, et D vide
        If Cells(L, "D") <> "" And Cells(L, "A") = "" Then
            Cells(L, "A") = Cells(L, "D")
            Cells(L, "D") = ""
        End If
        ' Si M non vide et E vide alors E=M, et M vide
        If Cells(L, "M") <> "" And Cells(L, "E") = "" Then
            Cells(L, "E") = Cells(L, "M")
            Cells(L, "M") = ""
        End If
        ' Si N non vide et G vide alors G=N, et N vide
        If Cells(L, "N") <> "" And Cells(L, "G") = "" Then
            Cells(L, "G") = Cells(L, "N")
            Cells(L, "N") = ""
        End If
    Next L
    Application.ScreenUpdating = True
End Sub
 

saggigo

XLDnaute Occasionnel
Bonsoir,
VB:
Sub Remplace()
    Application.ScreenUpdating = False: Dim L%
    For L = 2 To Range("C65500").End(xlUp).Row  ' Jusqu'à dernire ligne de C
        ' Si D non vide et A vide alors A=D, et D vide
        If Cells(L, "D") <> "" And Cells(L, "A") = "" Then
            Cells(L, "A") = Cells(L, "D")
            Cells(L, "D") = ""
        End If
        ' Si M non vide et E vide alors E=M, et M vide
        If Cells(L, "M") <> "" And Cells(L, "E") = "" Then
            Cells(L, "E") = Cells(L, "M")
            Cells(L, "M") = ""
        End If
        ' Si N non vide et G vide alors G=N, et N vide
        If Cells(L, "N") <> "" And Cells(L, "G") = "" Then
            Cells(L, "G") = Cells(L, "N")
            Cells(L, "N") = ""
        End If
    Next L
    Application.ScreenUpdating = True
End Sub
Parfait :):):) je suis super content, merci beaucoup Sylvanu. merci.
Sauf que j'ai du enlever les end if car j'avais un message d'erreur.
 

Statistiques des forums

Discussions
312 930
Messages
2 093 717
Membres
105 794
dernier inscrit
mallet