ameliorer code VBA Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
L
Ldopa
Membre fidèle
Membre fidèle
Messages : 166
Inscrit le : 19 septembre 2016
Version d'Excel : 2016 FR

Message par Ldopa » 15 décembre 2018, 20:42

Bonjour à toutes et à tous
J'ai trouver le code suivant qui me permet d'importer les valeurs des cellules d'un tableau vers un autre,
en triant en fonction d'un critère de champs.
.Range("$A$3:$U$103").AutoFilter Field:=6, Criteria1:="VTT"
    .Range("A4:D104").Copy
        Sheets("Paraphes").Range("AW11").PasteSpecial Paste:=xlPasteValues
    .Range("J4:J104").Copy
        Sheets("Paraphes").Range("AZ11").PasteSpecial Paste:=xlPasteValues

le problème est que si dans
"critérial
" il n'y a pas "VTT" par exemple alors le code importe tout le tableau.
est il possible de mettre une condition "if then" qui permettrait de garde la fiche vierge en cas d'absence d'un critère ?

Merci d'avance pour votre aide.
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'256
Appréciations reçues : 399
Inscrit le : 27 août 2012
Version d'Excel : O365 32 bits

Message par Jean-Eric » 15 décembre 2018, 21:05

Bonjour,
Merci de joindre un fichier à ta demande.
Cdlt.
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
L
Ldopa
Membre fidèle
Membre fidèle
Messages : 166
Inscrit le : 19 septembre 2016
Version d'Excel : 2016 FR

Message par Ldopa » 16 décembre 2018, 10:03

Bonjour Jean Eric
Je te joins l'adresse du fichier : https://www.cjoint.com/c/HLqi3C1GZUr
Le problème est sur la feuille "paraphes"," useform2" ,bouton de commande "paraphes".
Amicalement
Bernard
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'256
Appréciations reçues : 399
Inscrit le : 27 août 2012
Version d'Excel : O365 32 bits

Message par Jean-Eric » 16 décembre 2018, 11:16

Bonjour,
Pour le principe :
'Complète les feuilles pour paraphes des coureurs
Private Sub Paraphes_Click()
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, rng2 As Range

    Application.ScreenUpdating = False
    
    Set ws = ActiveWorkbook.Worksheets("Engag?s")
    Set ws2 = ActiveWorkbook.Worksheets("Paraphes")

    With ws
        If .FilterMode Then .ShowAllData
        Set rng = .Range("$A$3:$U$103")
        '1?re
        rng.AutoFilter Field:=6, Criteria1:="1?re"
        With .AutoFilter.Range
            On Error Resume Next
            Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                       .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rng2 Is Nothing Then
                rng2.Resize(, 4).Copy
                ws2.Cells(11, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                rng2.Offset(, 9).Copy
                ws2.Cells(11, 5).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
            End If
        End With
        '2?me.
        rng.AutoFilter Field:=6, Criteria1:="2?me"
        With .AutoFilter.Range
            On Error Resume Next
            Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                       .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rng2 Is Nothing Then
                rng2.Resize(, 4).Copy
                ws2.Cells(11, 9).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                rng2.Offset(, 9).Copy
                ws2.Cells(11, 13).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
            End If
        End With
        .AutoFilterMode = False
    End With
    Unload Me
End Sub
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
L
Ldopa
Membre fidèle
Membre fidèle
Messages : 166
Inscrit le : 19 septembre 2016
Version d'Excel : 2016 FR

Message par Ldopa » 16 décembre 2018, 12:29

Merci pour ton aide
J'ai essayé ton code.
Il fonctionne jusqu'au 2ème,
Mais à partir du 3ème j'ai erreur 1004 "erreur défini par l'application ou par l'objet
et le ligne
 rng2.Resize(, 4).Copy
est surlignée.
Je joins le code pour les 3ème caté.
'3?me.
rng.AutoFilter Field:=6, Criteria1:="3?me"
With .AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng2 Is Nothing Then
rng2.Resize(, 4).Copy
ws2.Cells(11, 17).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
rng2.Offset(, 9).Copy
ws2.Cells(11, 21).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End If
End With

encore merci pour ton aide.
A te relire
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'256
Appréciations reçues : 399
Inscrit le : 27 août 2012
Version d'Excel : O365 32 bits

Message par Jean-Eric » 16 décembre 2018, 12:33

Re,
J'ai fait pour les 2 premiers items.
Tu dois reproduire la chose pour les autres items !... :mrgreen:
Cdlt.
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
L
Ldopa
Membre fidèle
Membre fidèle
Messages : 166
Inscrit le : 19 septembre 2016
Version d'Excel : 2016 FR

Message par Ldopa » 16 décembre 2018, 12:36

re
C'est ce qu j'ai essayé, mis je ne comprend pas l'erreur 1004.
J'ai bien modifier les n° de cellule , mais pourquoi la ligne
rng2.Resize(, 4).Copy
est elle surlignée en jaune ?
D'avance merci
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'256
Appréciations reçues : 399
Inscrit le : 27 août 2012
Version d'Excel : O365 32 bits

Message par Jean-Eric » 16 décembre 2018, 12:47

Re,
Envoie ton classeur avec la procédure que tu as mise à jour.
Que je voie !...
Chaque erreur te sera facturée 10 EUR. :P
Cdlt.
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
L
Ldopa
Membre fidèle
Membre fidèle
Messages : 166
Inscrit le : 19 septembre 2016
Version d'Excel : 2016 FR

Message par Ldopa » 16 décembre 2018, 12:54

Waouh dur dur :cry:
Voici l'adresse
: HLql0GXG6Or_Classement-Cyclo-Cross-Rév-6-1travail-.xlsm ;;)
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'256
Appréciations reçues : 399
Inscrit le : 27 août 2012
Version d'Excel : O365 32 bits

Message par Jean-Eric » 16 décembre 2018, 13:00

Re,
Je pense que le Homard et le caviar seront sur ma table pour les fêtes !... ;;)
Je peux par MP te communiquer mes coordonnées bancaires.
A te relire.
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message