Cellule bloquée VBA

Résolu/Fermé

farreneit Messages postés 282 Date d'inscription jeudi 5 juillet 2012 Statut Membre Dernière intervention 13 janvier 2023 - 9 oct. 2020 à 17:11
farreneit Messages postés 282 Date d'inscription jeudi 5 juillet 2012 Statut Membre Dernière intervention 13 janvier 2023 - 9 oct. 2020 à 18:11

Bonjour,

Je suis actuellement en train de me créer un fichier d'automatisation sur Excel.
Toutefois, je bloque depuis plusieurs jours sur une partie.

Je souhaiterais créer une macro qui selectionne toutes les lignes du tableau où la dernière colonne possède un "!", qui les copie, les colle à la suite en remplacant le "!" par "003".

Attention, il faut que cela selectionne UNIQUEMENT les lignes où la dernière ligne possède un "!", peu importe le nombre de ligne qu'il y a (cela peu varier). Ainsi, il doit être possible de lancer 2x la macro d'affilés.

Le résultat que j'ai réussi à avoir est ci-dessous :

Toutefois, seulement la première ligne est copiée et non une ligne après l'autre. Ainsi, dans la colonne couleur, les bonnes valeurs ne sont pas copiées.

Ci-joint la macro correspndante :

Dim Counter
    Counter = 0

    Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C1,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C2,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C3,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C4,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C5,"""")"
    
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",""003"","""")"
    Range("A1").Select
    Selection.End(xlDown).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy

    While Counter < Range("compteur.de.pointexcla").Value
    
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.paste
    Counter = Counter + 1
    
    Wend

N'hésitez pas à me demander si vous avez besoin d'informations supplémentaires ou si vous voulez recevoir le fichier.

Merci d'avance !

Cordialement,
farreneit

A voir également:

Cellule bloquée VBA
Excel compter cellule couleur sans vba - Guide
Excel cellule couleur si condition texte - Guide
Boite gmail bloquée - Guide
Aller à la ligne dans une cellule excel - Guide
Proteger cellule excel - Guide

2 réponses

Réponse 1 / 2

yg_be Messages postés 23477 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 mars 2025 Ambassadeur 1 568
9 oct. 2020 à 17:44

bonjour, je suggère ceci:

Dim cl As Range, derlig As Long, lig As Long, nouvcel As Range
Set cl = [A2]
derlig = cl.End(xlDown).Row
Set nouvcel = Cells(derlig + 1, 1)
For lig = 2 To derlig
    If cl.Offset(, 5) = "!" Then
        cl.Resize(, 5).Copy nouvcel.Resize(, 5)
        nouvcel.Offset(, 5) = "'003"
        Set nouvcel = nouvcel.Offset(1)
    End If
    Set cl = cl.Offset(1)
Next lig

yg_be Messages postés 23477 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 mars 2025 1 568
9 oct. 2020 à 17:47

j'ai supposé que "la dernière colonne" était en fait la colonne F.

farreneit Messages postés 282 Date d'inscription jeudi 5 juillet 2012 Statut Membre Dernière intervention 13 janvier 2023 10
9 oct. 2020 à 17:50

Cela fonctionne parfaitement !
Vous avez trouvé en 5 petites minutes ce que je recherche depuis plusieurs heures ..

Pourriez-vous me donner une explication très rapide du fonctionnement de cette macro s'il vous plait ?

Encore merci !

yg_be Messages postés 23477 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 mars 2025 1 568 > farreneit Messages postés 282 Date d'inscription jeudi 5 juillet 2012 Statut Membre Dernière intervention 13 janvier 2023
9 oct. 2020 à 17:56

Option Explicit

Private Sub yyy()
Dim cl As Range, derlig As Long, lig As Long, nouvcel As Range
Set cl = [A2]     ' cellule en A2
derlig = cl.End(xlDown).Row  ' numéro de la dernière ligne à traiter
Set nouvcel = Cells(derlig + 1, 1) ' position où insérer une nouvelle ligne
For lig = 2 To derlig  'travaillons sur toutes les lignes à traiter
    If cl.Offset(, 5) = "!" Then    ' vérifions le contenu  décalé à droite de 5 colonnes
        cl.Resize(, 5).Copy nouvcel.Resize(, 5) ' recopions 5 colonnes vers la position où insérer
        nouvcel.Offset(, 5) = "'003"
        Set nouvcel = nouvcel.Offset(1) 'décalons la ligne où insérer d'une ligne vers le bas
    End If
    Set cl = cl.Offset(1)  'décalons la ligne à traiter d'une ligne vers le bas
Next lig

End Sub

farreneit Messages postés 282 Date d'inscription jeudi 5 juillet 2012 Statut Membre Dernière intervention 13 janvier 2023 10 > yg_be Messages postés 23477 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 mars 2025
9 oct. 2020 à 18:11

Très complexe pour moi !

J'étais en train de faire un système de boucles et de copiés collés.

Merci beaucoup !!
Très bonne soirée !

Réponse 2 / 2

yg_be Messages postés 23477 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 mars 2025 Ambassadeur 1 568
9 oct. 2020 à 17:30

bonjour, c'est, bien sûr, plus simple si tu partages le fichier, cela nous évite de recréer un exemple.

farreneit Messages postés 282 Date d'inscription jeudi 5 juillet 2012 Statut Membre Dernière intervention 13 janvier 2023 10
9 oct. 2020 à 17:33

Bonjour,

Merci pour votre réponse.
Il n'est à ma connaissance pas possible d'insérer un ficher dans le message ..
Si vous m'envoyez un mail je peux vous l'envoyer.

Merci !

pour partager ici un fichier, il suffit de publier le fichier sur internet (google drive, one drive, cjoint.com, ...), puis de partager ici le lien vers le fichier.

D'accord ! ce sera aussi fait la prochaine fois !

yg_be Messages postés 23477 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 1 mars 2025 1 568
Modifié le 9 oct. 2020 à 17:48

quand tu utilises les balises de code pour partager du VBA, peux-tu préciser le langage "basic"? merci!

Désolé, ca sera fait la prochaine fois !

Voici :

    Dim Counter
    Counter = 0

    Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C1,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C2,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C3,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C4,"""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",R2C5,"""")"

    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(R2C6=""!"",""003"","""")"
    Range("A1").Select
    Selection.End(xlDown).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy

    While Counter < Range("compteur.de.pointexcla").Value

    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.paste
    Counter = Counter + 1

    Wend

Discussions similaires

Erreur d'exécution 13 Incompatibilité de type

Quel fonction faire en b1 par rapport à a1

Excel formule : savoir si une cellule contient partie texte

Excel si cellule contient texte alors...