Raccourcir une formule

zeltron24 · 16 Mai 2014

Bonsoir à tous,

J'ai un petit souci de formule, dont voici le code :

Code:

Dim r As Range
Dim n As Byte

' Les Produits
Set r = su.Columns(2).Find(Me.CmbAfficher.Value, , xlValues, xlWhole)
If Not r Is Nothing Then
    test = True
    st.Range("A22").Value = r.Offset(0, 1)
    st.Range("A23").Value = r.Offset(1, 1)
    st.Range("A24").Value = r.Offset(2, 1)
    st.Range("A25").Value = r.Offset(3, 1)
    st.Range("A26").Value = r.Offset(4, 1)
    st.Range("A27").Value = r.Offset(5, 1)
    st.Range("A28").Value = r.Offset(6, 1)
    st.Range("A29").Value = r.Offset(7, 1)
    st.Range("A30").Value = r.Offset(8, 1)
    st.Range("A31").Value = r.Offset(9, 1)
    st.Range("A32").Value = r.Offset(10, 1)
    st.Range("A33").Value = r.Offset(11, 1)
    .......
    st.Range("A55").Value = r.Offset(22, 1)
End If

(Diminué pour la cause)
Voilà, je souhaiterai trouver un code moins long si cela est faisable. Le but étant de recopié les valeurs de la colonne A22 à A55 dans une autre feuille. Cette formule marche bien mais j'ai 3 colonnes à recopier.

Staple1600 · 17 Mai 2014

Re : Raccourcir une formule

Bonsoir à tous

zeltron24
J'ai précisé dans le précédent message

Ce genre de chose peut s'appeler adaptation de mon précédent code
Je te laisse, si cela te tente, la poursuivre

Et le nom de la macro est sans équivoque

Sub DebutAdaptation()

Staple1600 · 17 Mai 2014

Re : Raccourcir une formule

Re

Comme ma télé n'a pas su m'aguicher ce soir, j'ai poursuivi l'adaptation
Voici le résultat obtenu:

Code:

Sub FinAdaptation()
Dim dl&, x&, f As Worksheet: Set f = Sheets("Horaires")
Application.ScreenUpdating = False
x = f.Cells(55, "A").End(3).Row
f.Range(f.Cells(22, "A"), f.Cells(x, "A")).Copy
With Sheets("Suivi")
    dl = .Cells(Rows.Count, 3).End(3)(3).Row
    .Cells(dl, "C").PasteSpecial xlValues

    f.Range(f.Cells(22, "C"), f.Cells(x, "E")).Copy
    .Cells(dl, "D").PasteSpecial xlValues

    .Cells(dl, 1) = Date: .Cells(dl, 2) = f.[M26].Text

    .Range(.Cells(dl, 7), .Cells(dl, 10)) = _
    Array(f.[G46].Value, f.[G23].Range("A1").Value, f.[G29].Range("A1").Value, f.[G35].Range("A1").Value)

End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Il n'y pas de décalage, non ?

zeltron24 · 18 Mai 2014

Re : Raccourcir une formule

Bonjour Staple1600,

Super ton travail. cela marche correctement mis à part que j'ai une ligne vide en début d'enregistrement et que comme je ne comprends pas ton code, je n'arrive pas à la supprimer.

PS: Je n'ose plus transformer le code car celui ci fonctionne correctement.

Staple1600 · 18 Mai 2014

Re : Raccourcir une formule

Bonjour à tous

zeltron24
Si tu ne comprends pas, rien ne t’empêche de poser des questions sur les lignes qui te posent souci.

J'y répondrai.

Sinon pour cette histoire de ligne en trop, avec cette modif, c'est mieux ?

Code:

Sub FinAdaptationBis()
Dim dl&, x&, f As Worksheet: Set f = Sheets("Horaires")
Application.ScreenUpdating = False
x = f.Cells(55, "A").End(3).Row
f.Range(f.Cells(22, "A"), f.Cells(x, "A")).Copy
With Sheets("Suivi")
    dl = .Cells(Rows.Count, 3).End(3)(3).Row
    .Cells(dl, "C").PasteSpecial xlValues
    f.Range(f.Cells(22, "C"), f.Cells(x, "E")).Copy
    .Cells(dl, "D").PasteSpecial xlValues
    .Cells(dl, 1) = Date: .Cells(dl, 2) = f.[M26].Text
    .Range(.Cells(dl, 7), .Cells(dl, 10)) = _
    Array(f.[G46].Value, f.[G23].Range("A1").Value, f.[G29].Range("A1").Value, f.[G35].Range("A1").Value)
If Application.CountA(.Range("A2:J2")) = 0 Then .Range("A2:J2").Delete Shift:=xlUp
End With
Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub

zeltron24 · 18 Mai 2014

Re : Raccourcir une formule

Bonsoir Staple1600

Je reviens sur le sujet après une après Midi Foot.
Cela me ferait très plaisir si tu aurais quelques minutes afin de m'expliquer ton code.
De plus je joins le fichier avec ton code afin que tu puisses voir ou se citue le problème de ligne vide en début de chaque enregistrement.
Ces lignes vides m'empêchent de rééditer un ticket.

PS: Je te remercie vivement de te pencher sur mon souci. et te suis très reconnaissant.

Très cordialement
Un mou du ciboulot......

Staple1600 · 18 Mai 2014

Re : Raccourcir une formule

Bonsoir àtous

zeltron24
Pas le temps ce soir
Et je ne comprends pas car sur ton fichier il y a bien une ligne vide coloriée en gris, non ?
Donc si tu veux pas de ligne vide à chaque fois que tu lances la macro
Vois avec cette version modifiée

VB:

Sub FinAdaptationTer()
'Modifs pour suppression ligne intermédiaire
Dim dl&, x&, f As Worksheet: Set f = Sheets("Horaires")
Application.ScreenUpdating = False
x = f.Cells(55, "A").End(3).Row
f.Range(f.Cells(22, "A"), f.Cells(x, "A")).Copy
With Sheets("Suivi")
    dl = .Cells(Rows.Count, 3).End(3)(2).Row 'modif ici 2 au lieu de trois
    .Cells(dl, "C").PasteSpecial xlValues
    f.Range(f.Cells(22, "C"), f.Cells(x, "E")).Copy
    .Cells(dl, "D").PasteSpecial xlValues
    .Cells(dl, 1) = Date: .Cells(dl, 2) = f.[M26].Text
    .Range(.Cells(dl, 7), .Cells(dl, 10)) = _
    Array(f.[G46].Value, f.[G23].Range("A1").Value, f.[G29].Range("A1").Value, f.[G35].Range("A1").Value)
End With
Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub

zeltron24 · 18 Mai 2014

Re : Raccourcir une formule

Re,
Oui effectivement elle me sert à séparer les enregistrements.
C'est la ligne juste au dessus de la date qui me pose problème.
Super en remettant ton dernier code ce problème est résolu.
Encore mille Merci et bonne soirée.
A+

zeltron24 · 19 Mai 2014

Re : Raccourcir une formule

Bonsoir à tous,

Lorsque j'utilise ce code :

Code:

Private Sub CmbAfficher_Change()
Dim r As Range
Dim rg As Byte
Dim q As Byte
Dim n As Byte

Set su = Sheets("Suivi")

st.Range("K50") = "Oui"             ' Réédition d'un Ticket

' Les Produits
Set r = su.Columns(2).Find(Me.CmbAfficher.Value, , xlValues, xlWhole)
If Not r Is Nothing Then
    test = True
    rg = 22
    n = 1
    q = r.Offset(0, 9)
    For rg = 22 To 30
    For n = 1 To q
    st.Range("A" & rg).Value = r.Offset(n, 1)
    n = n + 1
    rg = rg + 1
    Next n
    Next rg
End If

je me retrouve avec le cas de figure (voir Post#9) (Copie de 2 lignes en continue)
J'essaie de trouver la solution afin de pouvoir éditer un ticket correspondant à la sélection de la liste déroulante de la feuille "Horaires" sans succès.
En clair, je cherche à recopier un Ticket en feuille "Suivi" sélectionné par liste déroulante sur la feuille "Horaires" de A22 à la valeur de la colonne K (Feuille "Suivi")
Si Qt Article =3 alors recopie valeur en A22 - A23 - A24
Merci pour votre aide et encore un grand merci à Staple1600 que je n'économise pas avec mes problèmes.

Staple1600 · 19 Mai 2014

Re : Raccourcir une formule

Bonsoir à tous

zeltron24
Je te laisse tester, adapter et continuer ce code
(ici j'ai testé sans me servir de la Combo, mais cela devrait fonctionner, je te laisse tester)

Code:

Sub z()
Dim x
x = 6 ' ici x est là juste pour tester sans passer par la combo
Dim r As Range
Dim n As Byte
Dim pl&, dl&
'ici utiliser ces lignes dans le code de ta Combo
' Les Produits
Set r = Sheets("Suivi").Columns(2).Find(x, , xlValues, xlWhole)
If Not r Is Nothing Then
pl = r.Row: dl = r.Offset(, -1).End(xlDown).Row - 1
With Sheets("Suivi")
    .Activate
    .Range(Cells(pl, 3), Cells(dl, 3)).Copy
    Sheets("Horaires").[A22].PasteSpecial xlValues
    .Range(Cells(pl, 4), Cells(dl, 4)).Copy
    Sheets("Horaires").[C22].PasteSpecial xlValues
End With
End If
End Sub

PS: Test OK sur ta PJ, la recopie se fait bien sur la feuille Horaires pour les colonnes Quantité et Prix

zeltron24 · 19 Mai 2014

Re : Raccourcir une formule

Bonsoir Staple1600,

Code:

Dim pl&, dl&

Pourquoi y a t-il pas de As ......
et

Code:

pl = r.Row: dl = r.Offset(, -1).End(xlDown).Row - 1

Je ne comprends pas la fonction r.Offset(,-1) il manque la valeur avant la "," Non ?
Peux tu m'expliquer SVP
Ceci afin de comprendre les modifications. Merci

Staple1600 · 19 Mai 2014

Re : Raccourcir une formule

Re

zeltron24
Pourquoi pas de As
Voir ici
https://www.excel-downloads.com/threads/vba-types-de-variables.81052/

pl pour première ligne, donc tu devines ce que veut dire dl
Pour Offset (voir l'aide pour les détails)
Mais Range("A1").Offset(0,1) peut s'écrire Range("A1").Offset(,1)
(Cela pour dire qu'on reste sur la même ligne donc 0 ou rien puisque facultatif)

Donc ici pl et dl me sert à déterminer la première et dernière lignes du ticket .
Ensuite il suffit de définir la plage de cellules à copier avec Range(cells(pl,NUMCOL), Cells(dl,NUMCOL))

Tu as testé le code avec le Combo ? Cela fonctionne ?

zeltron24 · 19 Mai 2014

Re : Raccourcir une formule

Re,

quelques petits souci de mise en place, mais je devrais y arriver.
Je ne parviens pas à trouver x
x = CmbAfficher.value est correct ?
Merci pour les explications.
de plus

Code:

    .Range(Cells(pl, 3), Cells(dl, 3)).Copy

se met en jaune

Staple1600 · 19 Mai 2014

Re : Raccourcir une formule

Re

Toujours lire les commentaires

Dim x
x = 6 ' ici x est là juste pour tester sans passer par la combo

Donc ne t'occupe de x, et utilises seulement les lignes utiles en les mettant dans ton code d'origine
(voir l'autre commentaire dans le code

)

j'ai repris ton code et insérer le mien mais je te laisse tester

VB:

Private Sub CmbAfficher_Change()
Dim r As Range
Dim pl&, dl&

' Les Produits
Set r = su.Columns(2).Find(Me.CmbAfficher.Value, , xlValues, xlWhole)
If Not r Is Nothing Then
pl = r.Row: dl = r.Offset(, -1).End(xlDown).Row - 1
With Sheets("Suivi")
    .Activate
    .Range(Cells(pl, 3), Cells(dl, 3)).Copy
    Sheets("Horaires").[A22].PasteSpecial xlValues
    .Range(Cells(pl, 4), Cells(dl, 4)).Copy
    Sheets("Horaires").[C22].PasteSpecial xlValues
End With
End If


'' ici aussi tu peux ou pas simplier selon la logique employer pour Produis et Quantité
'Set r = su.Columns(2).Find(Me.CmbAfficher.Value, , xlValues, xlWhole)
'If Not r Is Nothing Then
'    test = True
'    st.Range("G46").Value = r.Offset(0, 5)      ' Moyen de paiement
'End If
'
'    If Range("I22").Value = 1 Then
'    Especes = True
'    End If
'
'        If Range("I22").Value = 2 Then
'    Cheque = True
'    End If
'
'    If Range("I22").Value = 3 Then
'    Carte = True
'    End If
'
'CmbAfficher.Value = 0
'Range("M26").Select

End Sub

zeltron24 · 19 Mai 2014

Re : Raccourcir une formule

Re,

J'ai bien lu ton commentaire.

Code:

x = CmbAfficher.value

Me donne bien la valeur du combo ça c'est bon.
pl me donne 8 et dl me donne 12. Chiffre qui varie suivant le ticket sélectionné.
Ce qui ne m'évite pas d'avoir la ligne en jaune.
J'ai modifié le code en conséquence. dont voici l'extrait:

Code:

Set su = Sheets("Suivi")
Set st = Sheets("Horaires")
st.Range("K50") = "Oui"             ' Réédition d'un Ticket

Dim x As Byte
x = CmbAfficher.Value ' ici x est là juste pour tester sans passer par la combo
'ici utiliser ces lignes dans le code de ta Combo
' Les Produits
Set r = Sheets("Suivi").Columns(2).Find(x, , xlValues, xlWhole)
If Not r Is Nothing Then
pl = r.Row: dl = r.Offset(, -1).End(xlDown).Row - 1
With Sheets("Suivi")
    .Activate
   .Range(Cells(pl, 3), Cells(dl, 3)).Copy ' cette ligne est en jaune Erreur définie par l'application ou l'objet
    Sheets("Horaires").[A22].PasteSpecial xlValues
    .Range(Cells(pl, 4), Cells(dl, 4)).Copy
    Sheets("Horaires").[C22].PasteSpecial xlValues
End With
End If

zeltron24 · 19 Mai 2014

Re : Raccourcir une formule

Re, Je ne te retiens pas plus longtemps je vais me coucher demain boulot et la nuit porte conseil.
Bonne nuit à toi et encore merci très sincèrement.

Effectuez une recherche sur Excel Downloads...

Raccourcir une formule

zeltron24

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

zeltron24

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

zeltron24

XLDnaute Impliqué

Pièces jointes

Staple1600

XLDnaute Barbatruc

zeltron24

XLDnaute Impliqué

zeltron24

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

zeltron24

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

zeltron24

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

zeltron24

XLDnaute Impliqué

zeltron24

XLDnaute Impliqué

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums