Etendre une cellule relatives VBA

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 on peut voir que

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.

Merci d'avance !

Cordialement,

farreneit

Bonjour,

Voici un essai. Il faudra cependant définir votre plage sous forme d'un tableau structuré (Insertion/Tableau) et supprimer les lignes vides à la fin (sinon, la copie se fera pas au bon endroit). Et dans le code, il faudra adapter en renommant "montableau" par le vrai nom de votre tableau.

Je n'ai pas testé donc le risque d'erreurs n'est pas nul :

Sub CopierExclam()

Dim montab as range, rCopie as range, rNvtab as range, rModif as range
Dim dl%

Set montab = Range("nomdutableau") '<<<< ici, a adapter
Set rCopie = SpecificRows(montab, "!") 'ensemble des lignes du tableau avec "!" en colonne 6
dl = montab.rows.count 'nb lignes du tableau (hors en-tetes)

if not rCopie is nothing then 'si non vide
    rCopie.copy montab.offset(dl, 0) 'copie à la fin du tableau
    Set rNvtab = range("montableau") '<<<< adapter ! contient le nouveau tableau agrandi
    Set rModif = Exclude(rNvtab, montab) 'renvoie le nv tableau moins l'ancien
    rModif.columns(6).value = "003" 'attribue la valeur "003" à la colonne 6 des nouvelles cellules du tableau
end if

End sub

'FONCTION RENVOYANT L'ENSEMBLE DES LIGNES D'UNE PLAGE REPONDANT A UN CRITERE (TESTE EN COLONNE 6)
Function SpecificRows(Plage As Range, Valeur_Critere As Variant) As Range

For Each cell In Plage.columns(6) 'pour chaque cellule de la colonne 6 de la plage
    If cell.Value = Valeur_Critere Then 'si la cellule vaut Valeur_Critere
        If SpecificRows Is Nothing Then 'si SpecificRows est vide (pas encore initialisé)
            Set SpecificRows = intersect(Plage, rows(cell.row)) 'SpecificRows contient la ligne de cell dans le tableau
        Else
            Set SpecificRows = Union(SpecificRows, intersect(Plage, rows(cell.row))) 'sinon, SpecificRows est l'union du précédent SpecificRows et de la ligne de la cellule en cours
        End If
    End If
Next

End Function

'FONCTION PERMETTANT DE RENVOYER L'UNION MOINS L'INTERSECTION DE 2 PLAGES
Function Exclude(Plage1 As Range, Plage2 as range) As Range

Dim rUnion as range, rInter as range

Set rUnion = union(Plage1, Plage 2)
Set rInter = Intersect(Plage1, Plage2)

For Each cell In rUnion 'pour chaque cellule de l'union des plages
    If Intersect(rInter, cell) is nothing Then 'si la cellule n'appartient pas à l'intersection
        If Exclude Is Nothing Then 'si Exclude est vide (pas encore initialisé)
            Set Exclude = cell 'Exclude contient la cell en cours
        Else
            Set Exclude = Union(Exclude, cell) 'sinon, Exclude est l'union du précédent Exclude et de la cellule en cours
        End If
    End If
Next

End Function

Cdlt,

Bonsoir,

Comme je m'étais penché sur le sujet, je poste aussi mon bout de code minable, mais qui a l'air de fonctionner malgré tout :D

Sub exclamation()
Dim fin, fin2 As Integer
fin = Cells(1, 1).End(xlDown).Row
fin2 = fin
For i = 2 To fin
    If Cells(i, Application.CountA(Range("A" & i & ":G" & i))).Value = "!" Then
        Range(Cells(i, 1), Cells(i, Application.CountA(Range("A" & i & ":G" & i)) - 1)).Copy Destination:=Range("A" & fin2 + 1)
        Cells(fin2 + 1, Application.CountA(Range("A" & i & ":G" & i))).Value = Format(CStr("003"), "000")
    Else:
    End If
fin2 = fin2 + 1
Next
End Sub

Elle prend normalement en compte la possibilité que le point d'exclamation ne soit pas en colonne F, mais en E