XL 2016 resumer code vba

[lamho27]

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

 

[vgendron]

Bonjour

simplifier comme ca?

Sub Button()
Range("B1:G40").SpecialCells(xlCellTypeConstants).Copy Destination:=Range("H1")
End Sub

 

[lamho27]

bonjour vgendron
je vous envoie mon fichier
pouvez-vous me voir, merci

 

[Staple1600]

Bonjour le fil, le forum

@lamho27
Essaie cette macro qui semble faire le job, non ?

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

Sub b()
Application.ScreenUpdating = False
[B1:G32].Copy: [H2].PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
Selection.SpecialCells(4).Delete -4162: [H2].Select
End Sub

 

[lamho27]

bonjour Staple1600
ton code ne marche pas si on clique 2eme fois

 

[Staple1600]

Re

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

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

 

[lamho27]

bonjour Staple1600
pouvez-vous voir que je fais , toujours pas

 

[Dranreb]

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.

 

[Staple1600]

Bonjour Dranreb

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

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

 

[Dranreb]

Chez moi non: en ne collant pas les cellules vides de la plage source, cela laissait à leurs emplacements dans la cible les anciennes déjà tassées.

 

[Dranreb]

@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.

 

[Staple1600]

Re

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.

 

[Dranreb]

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.

 

[mapomme]

Bonjour à tous,

Une autre manière de faire ? :

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

 

[lamho27]

oui Draureb; qui peut m'aider ?