pareil

Bizarre

Voilà ce que ça me donne :

Au départ :

Après un clic :

Après deux clics :

Comme ça c'est bon mais je trouve ça un peux long:


Private Const Depart As Long = 1


Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim Ligne As Long

For K = 1 To 1000
Ligne = (Range("B56000").End(xlUp).Row + 5)

    Range("B" & Ligne) = Range("A" & Ligne)
    Range("c" & Ligne) = Range("A" & Ligne + 1)
    Range("d" & Ligne) = Range("A" & Ligne + 2)
    Range("e" & Ligne) = Range("A" & Ligne + 3)
    Range("f" & Ligne) = Range("A" & Ligne + 4)

Next K

                             'Supprimer lignes
    Dim i As Long
    Dim DLV As Long: DLV = FinLigneVide

For i = DLV To Depart Step -1
    If Cells(i, 1).Value = vbNullString Or Cells(i, 2).Value = vbNullString Then Rows(i).Delete
    
    Next i
    
    Columns("A:A").ClearContents
    
Application.ScreenUpdating = True

End Sub


Private Function FinLigneVide() As Long
Dim Ligne As Long
Ligne = (Range("B56000").End(xlUp).Row)
    FinLigneVide = (Range("A" & Ligne).Row + 4)
End Function




ps:

marculinos, si tu veux que ta macro prenne de la vitesse lors d'exécution, insert le script suivant

Au Début de la macro:

Application.ScreenUpdating = False

Et à la fin de la macro:

Application.ScreenUpdating = True

Ce qui va donner:

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
'Selection de la cellule A1
Cells(1, 1).Select

'Détection du nombre total de lignes dans la colonne 1
a = 1
Do Until ActiveCell.Value = ""
    ActiveCell.Offset(1, 0).Select
    a = a + 1
Loop

a = a - 1
a = a / 5

'Selection de la cellule A1
Cells(1, 1).Select

For B = 1 To a
    Cells(B, 1).Select
    Selection.Cut
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, -1).Select
    Selection.Cut
    ActiveCell.Offset(-1, 2).Select
    ActiveSheet.Paste
    ActiveCell.Offset(2, -2).Select
    Selection.Cut
    ActiveCell.Offset(-2, 3).Select
    ActiveSheet.Paste
    ActiveCell.Offset(3, -3).Select
    Selection.Cut
    ActiveCell.Offset(-3, 4).Select
    ActiveSheet.Paste
    ActiveCell.Offset(4, -4).Select
    Selection.Cut
    ActiveCell.Offset(-4, 5).Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, 0).Select
    ActiveCell.EntireRow.Delete
    ActiveCell.EntireRow.Delete
    ActiveCell.EntireRow.Delete
    ActiveCell.EntireRow.Delete
    a = a - 4
Next
Application.ScreenUpdating = True
End Sub


Salut à tous,

Voici un petit truc marrant qui fait la même chose:

Sub Macro1()

Dim LigneB As Integer, Colonne As Integer
Nbrelignes = 1
LigneB = 1
Colonne = 2
Cells(1, 1).Select
Do Until ActiveCell.Value = ""
Cells(LigneB, Colonne).Value = ActiveCell.Value
ActiveCell.Value = ""
Colonne = Colonne + 1
If Colonne > 6 Then
Colonne = 2: LigneB = LigneB + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub

@+

Super Lebabs, très court comme script aussi

Donc 3 façons de faire la même chose et pourtant, il y à encore beaucoup d'autre façon de le faire.

C'est clair.

Par contre ta commande Application.ScreenUpdating m'intéresse très fortement pour mon programme au boulot. En effet, une partie de celui-ci repose sur une recherche de valeur par scrutation sur 8 colonnes (colonne par colonne, chacune faisant environ 300 lignes) et 6 fois de suite, ce qui prend pas loin d'une minute en incluant le temps de recopie des informations dans une autre feuille en cas de corrélation avec la date demandée. Je vais vraiment gagner du temps, je pense.

Ce que j'aime avec VBA, c'est qu'il y a mille et une façons d'arriver à un même résultat. Et l'expérience m'a prouvé que rien n'est impossible, sauf faire la vaisselle ou le ménage, mais ceci est une autre histoire.
@+

Et puis Marculinos.

Tu as essayé à ton travail:



Application.ScreenUpdating = False
et


Application.ScreenUpdating = True