XL 2016 resumer code vba

lamho27 · 22 Octobre 2017

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

Staple1600 · 22 Octobre 2017

Bonjour mapomme

C'est la même méthode, non?

'[B1:G32].Copy: Cells(Rows.Count, "H").End(xlUp)(2).PasteSpecial -4104
.Range("B:G").Copy .Range("H:M")
.Range("H:M").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
'idem:Selection.SpecialCells(4).Delete -4162

Sauf que tu copies les colonnes entières

@lamho27
On se sait pas comment est alimentée la plage B1:G32.
Est-ce qu’après la recopie, elle est effacée manuellement?
Et qu'ensuite tu y saisis de nouvelles dates?

mapomme · 22 Octobre 2017

Bonjour lamho27 ,

As tu vu le message #14 de ma pomme ?

lamho27 · 22 Octobre 2017

Bonjour mapomme
merci ton code ; très bien que je veux

mapomme · 22 Octobre 2017

Bonjour Staple1600 ,

Staple1600 à dit:
C'est la même méthode, non?
Sauf que tu copies les colonnes entières

Tout à fait, c'est ça la différence qui justifie "une autre manière". Il m'en faut peu

Staple1600 · 22 Octobre 2017

Re mapomme

Tu peux m'expliquer le pourquoi de ta boucle, stp?
For i = 1 To .Rows.Count
If Application.WorksheetFunction.Count(.Range("h" & i & ":m" & i)) = 0 Then Exit For
Next i

(Je suis pas encore bien réveillé )

EDITION:
Il me manquait juste cette ligne, si j"ai bien compris

VB:

Sub aa()
Application.ScreenUpdating = False
If Len([H2]) > 0 Then Exit Sub
[B1:G32].Copy: [H2].PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
Selection.SpecialCells(4).Delete -4162: [H2].Select
End Sub

mapomme · 22 Octobre 2017

Re Staple1600 ,

Maintenant que tu es redevenu visible...

Je recherche simplement la première ligne i entièrement vide des colonnes h à m pour appliquer aux lignes 1 à (i-1) l'encadrement pointillé. C'est pas optimisé mais ça le fait .

mapomme · 22 Octobre 2017

Re Staple1600 ,

Une autre petite différence, me semble-t-il, est que ma macro prend en compte les modifications du tableau source entre deux exécutions. Ta macro, une fois exécutée, ne retraite pas les données sources ( du moins, il me semble).

Staple1600 · 22 Octobre 2017

Re

@mapomme
Je suis pas réveillé avais-je dit
De quelle visibilité, tu parles?

C'est normal, le dimanche, mes macros ne se lancent qu'une fois!
C'est un jour de repos.

mapomme · 22 Octobre 2017

Re,

Staple1600 à dit:
De quelle visibilité, tu parles?

Il m'avait semblé avoir lu deux fils de discussions assez récents où tes réponses semblaient invisibles ...

vgendron · 22 Octobre 2017

Hello le forum
bizarre effectivement, ma proposition ne fonctionne pas sur le fichier posté par Lamho27, lequel contient des dates

alors que ca fonctionnait bien sur le fichier que je m'étais créé et qui ne contenait que des chiffres...
cf feuille2 du classeur

sans doute qu'excel n'aime pas la correspondance xlcelltypeconstant avec des dates....

XL 2016 resumer code vba

lamho27

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

lamho27

XLDnaute Occasionnel

mapomme

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

vgendron

XLDnaute Barbatruc

Pièces jointes

Discussions similaires