Ma méthode VBA plante

Bonjour,

Je suis entrain de développer une méthode VBA qui a pour objectif de séparer dans la colonne lib les caractères étoiles et les autres en déplacant les lignes avec les caractère diffèrent d'un cran.
Seulement lorsque je lance ma méthode, tout mon logiciel excel plante et je dois retourner sur un back-up.
Je vous mets si joint une photo de la colonne étudié ainsi que de mon code.

En vous remerciant par avance, Luc.

Sub Gestion_des_etoiles()
'
' Gestion_des_etoiles Macro
'

ligne = 1
colonne = 1
    While IsEmpty(Cells(ligne, colonne)) = False
        If Cells(ligne, colonne).Value! = "***" Or Cells(ligne, colonne).Value! = "**" Or Cells(ligne, colonne).Value! = "*" Then
            'deplacer la case selectionner par rapport aux coord indqué d'une case
            ligneB = ligne
            While IsEmpty(Cells(ligneB, colonne)) = False
                ligneB = ligneB + 1
            Wend
            ActiveSheet.Range(Cells(ligne, colonne), Cells(ligneB, colonne)).Select
            Selection.Offset(0, 1).Select
            Exit Sub
         End If
    Wend
    Application.Goto Reference:="Gestion_des_etoiles"
    ActiveWorkbook.Save
End Sub

Bonjour,

Une proposition ?

Cdlt.

Public Sub XXX()
Dim lastRow As Long, lRow As Long
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For lRow = 2 To lastRow
            If Not VBA.InStr(1, .Cells(lRow, 1).Value, "*") > 0 Then
                .Cells(lRow, 2).Value = .Cells(lRow, 1).Value
                .Cells(lRow, 1).Value = vbNullString
            End If
        Next lRow
    End With
End Sub

Bonjour,

Je ne suis pas certain d'avoir compris mais pouvez-vous essayer comme ceci :

Sub Gestion_des_etoiles()

Dim rlib as range, rstar as range

Set rlib = Sheets("nomfeuille").range("Lib") '<<<< ADAPTER NOM DE LE FEUILLE VISEE, NOMMER LA PLAGE CIBLEE Lib

for each cell in rlib 'pour chaque cellule de Lib
    if cell.Value like "*[*]*" Then 'si cell contient "*"
        if rstar is nothing then set rstar = cell 'si rstar est vide, initialisé par première cell avec étoile
        set rstar = union(rstar, cell) 'sinon, rstar vaut star + cell étoile en cours
    end if
next cell

with rstar 'avec rstar
    .offset(0, 1).value = .value 'copie de la valeur des cellules dans colonne juste à droite
    .clearcontents 'contenus effacés
end with

'rlib.resize(rlib.count, 2).specialcells(xlcelltypeblanks).delete shift:=xlshiftup 'pour supprimer tous les vides...

end sub

en modifiant dans le code le nom de la feuille et en nommant au préalable la plage Lib.

Edit : Bonjour Jean-Eric

Cdlt,

Merci à tous je crois avoir saisie la proposition de Jean Eric, seulement au lieu de déplacer juste la case qui ne correspond pas aux étoiles sur la droite j'aimerais déplacer la ligne entière d'un cran. J'ai donc repris le code de Jean Eric et j'ai essayé d'y apporter une modification.
C'est la première macro que je tente de réaliser, j'ai encore pas mal de lacune.
En vous remerciant.

Sub Gestion_des_etoiles()

Dim lastRow As Long, lRow As Long
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For lRow = 2 To lastRow
            If Not VBA.InStr(1, .Cells(lRow, 1).Value, "*") > 0 Then
                lastColumn = .Cells(lRow, .Columns.Count).End(xlUp).Range
                For lColumn = 1 To lastColumn
                    .Cells(lRow, lastColumn).Value = .Cells(lRow, lColumn - 1).Value
                    .Cells(lRow, 1).Value = vbNullString
                Next lColumn
            End If
        Next lRow
    End With
End Sub

Bonjour,

D'accord, je pense avoir mieux compris. Pour le sport, je mets ma version retravaillée :

Sub Gestion_des_etoiles()

Dim rlib as range, rvaleurs as range, rdecal as range

Set rlib = Sheets("nomfeuille").range("Lib") '<<<< ADAPTER NOM DE LE FEUILLE VISEE, NOMMER LA PLAGE CIBLEE Lib

for each cell in rlib 'pour chaque cellule de Lib
    if not cell.Value like "*[*]*" Then 'si cell ne contient pas "*"
        if rvaleurs is nothing then set rvaleurs = cell 'si rvaleurs est vide, initialisé par première cell sans étoile
        set rvaleurs = union(rvaleurs, cell) 'sinon, rvaleurs vaut rvaleurs + cell sans étoile en cours
    end if
next cell

set rdecal = intersect(Sheets("nomfeuille").usedrange, rvaleurs.rows) 'intersection de la zone utilisée et des lignes de rvaleurs
rdecal.offset(0, 1).value = rdecal.value 'déplacement des valeurs des cellules dans colonnes à droite
rvaleurs.clearcontents 'contenus effacés

end sub

Sinon, concernant cette ligne

lastColumn = .Cells(lRow, .Columns.Count).End(xlUp).Range

En fait, .Cells(lRow, .Columns.Count).End(xlUp) renvoie déjà un objet range. En demandant la propriété .column de ce range, vous pouvez obtenir la colonne. Mais dans ce cas, il faudra aller vers la gauche car on part de la dernière colonne :

lastColumn = .Cells(lRow, .Columns.Count).End(xltoleft).column

Cdlt,

Re,

Une mise à jour ?

Public Sub XXX()
Dim lastRow As Long, lRow As Long
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For lRow = 2 To lastRow
            If Not VBA.InStr(1, .Cells(lRow, 1).Value, "*") > 0 Then
                .Cells(lRow, 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next lRow
    End With
End Sub

Je te remercie !
Grace a toi j'ai compris cette ligne mystérieuse !
Je partage mon code qui est un peu diffèrent :)

Sub Gestion_des_etoiles()

Dim lastRow As Long, lRow As Long

    With ActiveSheet 'dans la feuille de caclul
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'la derniere cellule
        For lRow = 2 To lastRow
            If Not VBA.InStr(1, .Cells(lRow, 1).Value, "*") > 0 Then
                lastcolumn = .Cells(lRow, .Columns.Count).End(xlToLeft).Column
                .Range(Cells(lRow, 1), Cells(lRow, lastcolumn)).Cut
                .Range(Cells(lRow, 1), Cells(lRow, lastcolumn)).Select
                ActiveCell.Offset(0, 1).Select
                ActiveSheet.Paste
            End If
        Next lRow
    End With
End Sub