bonjour a tous
j'ai une code vba integer mais trop long , pouvez-vous me modifier pour simplement mon code; merci d'avance
Sub Button()
Dim j As Integer
j = 1
For i = 1 To 40
If Not IsEmpty(Range("B" & i).Value) Then
Range("H" & j + 1).Value = Range("B" & i).Value
j = j + 1
End If
Next i
j = 1
For i = 1 To 40
If Not IsEmpty(Range("C" & i).Value) Then
Range("I" & j + 1).Value = Range("C" & i).Value
j = j + 1
End If
Next i
j = 1
For i = 1 To 40
If Not IsEmpty(Range("D" & i).Value) Then
Range("J" & j + 1).Value = Range("D" & i).Value
j = j + 1
End If
Next i
j = 1
For i = 1 To 40
If Not IsEmpty(Range("E" & i).Value) Then
Range("K" & j + 1).Value = Range("E" & i).Value
j = j + 1
End If
Next i
j = 1
For i = 1 To 40
If Not IsEmpty(Range("F" & i).Value) Then
Range("L" & j + 1).Value = Range("F" & i).Value
j = j + 1
End If
Next i
j = 1
For i = 1 To 40
If Not IsEmpty(Range("G" & i).Value) Then
Range("M" & j + 1).Value = Range("G" & i).Value
j = j + 1
End If
Next i
End Sub
@lamho27
Essaie cette macro qui semble faire le job, non ?
VB:
Sub a()
Range("B1:G32").Copy
Range("H2").PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
La même après un petit régime
VB:
Sub b()
Application.ScreenUpdating = False
[B1:G32].Copy: [H2].PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
Selection.SpecialCells(4).Delete -4162: [H2].Select
End Sub
Comme il marche quand on clique une première fois, moi ca me va
NB: Où est-il écrit qu'il faille cliquer plusieurs fois?
Et avec cette version, tu peux cliquer jusqu'à plus soif
VB:
Sub b()
Application.ScreenUpdating = False
[B1:G32].Copy: Cells(Rows.Count, "H").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
Selection.SpecialCells(4).Delete -4162: [H2].Select
End Sub
Bonjour.
Avec SkipBlanks:=False ça va mieux tout de même.
Edit: Ça allait mieux tout du moins s'il fallait écraser ce qu'il y avait en H:M, mais ça a l'air différent maintenant.
Je ne vois pas de différence sur le classeur de test en mettant sur False
Le résultat est le même chez moi.
(je parle de la macro b)
Et même avec celle-ci
VB:
Sub c()
Application.ScreenUpdating = False
[B1:G32].Copy: Cells(Rows.Count, "H").End(xlUp)(2).PasteSpecial -4104
Selection.SpecialCells(4).Delete -4162: [H2].Select
End Sub
La copie se fait en H2 et on décale les cellules non vides vers le haut
@vgendron: Merci d'avoir initié le style de la simplification possible, mais après vérification, votre solution ne fonctionne pas chez moi. Erreur 1004.
Je suis sur Excel 2013 (pas très différent de 2016)
Les 3 macros fonctionnent pourtant chez moi.
Ici résultat de la macro a
Ici résultat de la macro c aprés 4 exécutions de celle-ci
Par contre effectivement, avec le code de vgendron, Excel refuse la sélection multiple pour la copie et j'ai aussi un message d'erreur.
Même sans avoir vidé ce qu'il y a déjà en H:M ? Chez moi plein de dates se retrouvaient dupliquées à chaque clic sur le bouton. Et c'est probablement ce que voulais dire lamho27 au #5.
Sub SupprVide()
Dim i&
Application.ScreenUpdating = False
With Worksheets("Feuil1")
On Error Resume Next
.Range("B:G").Copy .Range("H:M")
.Range("H:M").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
For i = 1 To .Rows.Count
If Application.WorksheetFunction.Count(.Range("h" & i & ":m" & i)) = 0 Then Exit For
Next i
.Range("h1:M" & i - 1).Borders.LineStyle = xlDot
End With
End Sub