Copier coller avec condition

Ines2412 -  
yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,

Je suis novice sur VBA, et j'ai un souci :

Je commence par effacer les données d'un onglet pour copier coller de nouvelle valeurs puis
Je souhaiterai faire un copier coller des valeurs filtrés (jusque la tout va bien) mais si aucun résultat je souhaiterai qu'il n'y ai aucun résultat or dans l'onglet j'ai un message d'erreur et en faisant une gestion d'erreur il me colle toute les résultats

Voci la partie concernée :

    'nb de fichiers à traiter
    NbFc = Range("TbFic").Rows.Count
For x = 3 To NbFc + 3
    Dir = "DDD"
    Ag = Sheets("Table de concordance").Range("B" & x).Offset(0, -1).Value
    Fc = Sheets("Table de concordance").Range("B" & x).Offset(0, 1).Value
    Dossier = Sheets("Table de concordance").Range("B" & x).Value
    Workbooks.Open ChemApp & "\" & Dossier & "\" & Fc
    Set WbFc = Workbooks(Fc)
    
     
'on rappatrie les données  de boxi sur
    WbApp.Activate
'on met les filtres
    Sheets("Stocks").Activate
    Set Plg = Range("TbBoxi")
    
'on filtre sur l'agence à traiter - 
            On Error Resume Next    'Erreur si aucun filtre présent
            Range("TbBoxi[#Headers]").Select
            ActiveSheet.ShowAllData 'suppression des filtres
            Plg.AutoFilter Field:=2, Criteria1:=Ag, Operator:=xlAnd
            Plg.AutoFilter Field:=5, Criteria1:="Attribution "
            Plg.AutoFilter Field:=14, Criteria1:="Oui"
            On Error GoTo 0 'annule la gestion d'erreur

'On rapattrie les données du fichierGV - Requête BO stock -
'On vide le fichier "1- GV.xls" de versement onglet Requete Bo Stock 'TbRqBo
With Workbooks("1- GV.xls").Sheets("Requête BO Stock").ListObjects(1)
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    
End With    'Range("S2").FormulaR1C1 = "=RAND()"
    Workbooks("1- Garantie de versement.xls").Sheets("Requête BO Stock").Range("TbRqBo[Fonction aléa]").Cells(1, 1).FormulaR1C1 = "=RAND()"
    Set Plg = Range("TbBoxi").SpecialCells(xlCellTypeVisible)
    Plg.Copy Workbooks(Fc).Sheets("Requête BO Stock").Range("A2")


Je vous remercie pour votre aide

EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.

3 réponses

  1. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 588
     
    bonsoir, quand tu fais "On Error Resume Next", tu décides: "si il y a une erreur, je continue l'instruction suivante comme si tout allait bien, comme si il n'y avait pas d'erreur".
    j'imagines que tu souhaites faire autre chose en cas d'erreur.
    peut-être souhaites-tu passer à l’occurrence suivante du "for x"?
    cependant, tu n'expliques pas quoi, et tu ne partages qu'une partie de ton code.

    par ailleurs, il est souvent préférable de prévenir les erreurs au lieu d'y réagir.
    0
  2. Ines2412
     
    Bsr,

    Merci pr la réponse

    En fait je souhaiterai en cas d'erreur (dans le cas où mon filtre n'a aucune occurence) qui l efface bien les données du fichier requête bo et qu'il passe à un autre fichier
    0
    1. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   1 588
       
      pour commencer, peux-tu montrer le code complet, du for an next?
      pour continuer, indiquer à quelles lignes de code correspondent "efface les données du fichier requête bo".
      0
  3. Ines2412
     
    Bonjour voici le code entier :

    Sub OuvrFich()
    Application.ScreenUpdating = False
    Dim Dir As String
    Dim c As Range, Plg As Range
    Dim Ag As String, Dossier As String, Fc As String
    Dim DerLgAg As Integer, j As Byte
    
    'Boucle pour choisir le fichier Ag à traiter
        'nb de fichiers à traiter
        NbFc = Range("TbFic").Rows.Count
    For x = 3 To NbFc + 3
        Dir = "DDD"
        Ag = Sheets("Table de concordance").Range("B" & x).Offset(0, -1).Value
        Fc = Sheets("Table de concordance").Range("B" & x).Offset(0, 1).Value
        Dossier = Sheets("Table de concordance").Range("B" & x).Value
        Workbooks.Open ChemApp & "\" & Dossier & "\" & Fc
        Set WbFc = Workbooks(Fc)
        
         
    'on rappatrie les données  de boxi sur
        WbApp.Activate
    'on met les filtres
        Sheets("Stocks").Activate
        Set Plg = Range("TbBoxi")
        
    'on filtre sur l'agence à traiter -  GV
                On Error Resume Next    'Erreur si aucun filtre présent
                Range("TbBoxi[#Headers]").Select
                ActiveSheet.ShowAllData 'suppression des filtres
                Plg.AutoFilter Field:=2, Criteria1:=Ag, Operator:=xlAnd
                Plg.AutoFilter Field:=5, Criteria1:="Attribution "
                Plg.AutoFilter Field:=14, Criteria1:="Oui"
                On Error GoTo 0 'annule la gestion d'erreur
    
    'On rapattrie les données du fichier GV - Requête BO stock -
    'On vide le fichier "1- GV.xls" de versement onglet Requete Bo Stock 'TbRqBo
    With Workbooks("1- GV.xls").Sheets("Requête BO Stock").ListObjects(1)
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    End With    'Range("S2").FormulaR1C1 = "=RAND()"
        Workbooks("1- Garantie de versement.xls").Sheets("Requête BO Stock").Range("TbRqBo[Fonction aléa]").Cells(1, 1).FormulaR1C1 = "=RAND()"
    
      NbLg = Application.Subtotal(103, Columns("B")) 'si = 3 alors filtre vide (totaux)
            'on copie colle les données de boxi sur le fichier agence
            If NbLg >= 2 Then
                DerLgAg = Workbooks(Fc).Sheets("Requête BO stock").Range("A" & Rows.Count).End(xlUp).Row + 1
                '#Sélection de la plage à copier#
                    Set Plg = Range("TbBoxi").SpecialCells(xlCellTypeVisible)
                        If DerLgAg = 2 And Range("A2") = "" Then '
                            DerLgAg = 2
                            Plg.Copy Workbooks(Fc).Sheets("Requête BO Stock").Range("A" & DerLgAg)
                        Else
                            Plg.Copy Workbooks(Fc).Sheets("Requête BO Stock").Range("A" & DerLgAg)
                        End If
        
        'Set Plg = Range("TbBoxi").SpecialCells(xlCellTypeVisible)
        'Plg.Copy Workbooks(Fc).Sheets("Requête BO Stock").Range("A2")
        
            
    
    ' RECUP DES NOMS & NIR A SUPERVISER POUR LE MOIS PRECEDENT
    ' Filtre le mois précédent
    Dim NoLg As Integer, Supv As Range, i As Byte
    Dim Doss As String, Lg As Long, a As Byte 'utile pour Do while
    Application.ScreenUpdating = False
    
    With Workbooks("1- GV.xls").Sheets("Requête BO Stock").Activate
          '    On supprime les tries précédent et on trie sur les aléas
               Sheets("Requête BO Stock").Range("TbRqBo").Sort _
                key1:=Range("TbRqBo[Fonction aléa]"), order1:=xlAscending, Header:=xlYes
        'on copie Le 1er Nom / NIR de Requête BO et on les colle dans Saisies s'il ne fait pas doublon
       
        If Sheets("Saisies").Range("B6") = "" Then
            Range("C2:D2").Copy
                  Sheets("Saisies").Range("B6").PasteSpecial Paste:=xlPasteValues
        
        
        Else
            '   sinon, on prend le suivant
            a = 2   'indice ligne du Nir testé
                Doss = Range("D" & a)   'Nir à vérifier
                'dernière ligne de saisies
            With Sheets("Saisies")
                DerLg = .Range("B" & Rows.Count).End(xlUp).Row
            'on vérifie l'existance du 1er nir
                Set Plg = .Range("C6:C" & DerLg)
                Do While Application.WorksheetFunction.CountIf(Plg, Doss) >= 1
                    MsgBox " Le nir a déjà été mis en supervision, nous testons le suivant."
                    a = a + 1
                    Doss = Range("D" & a)   'Nir à vérifier
                Loop
            End With
                    'on copie colle le nouveau Nir de Requete BO Stock sur Saisie
                    Range("C" & a & ":D" & a).Copy
                    Sheets("saisies").Range("b" & DerLg + 1).PasteSpecial Paste:=xlPasteValues
         End If
         
    Workbooks(Fc).Sheets("Saisies").Activate
    Workbooks(Fc).Close True
    
    'WbFc.Close True
    Set WbFc = Nothing
    Application.ScreenUpdating = True
    
    End With
    
    'on enlève les filtres
            Range("TbBoxi[#Headers]").Select
            ActiveSheet.ShowAllData 'suppression des filtres
    'On libère la mémoire
            Set Plg = Nothing
    Application.ScreenUpdating = True
     End If
     Next
    End Sub


    En fait, au moment ou l'onglet se vide si aucune occurence n'est trouvé dans le fichier de base, je souhaiterai qu'il reste vide et non qu'il me copie toute la base de données

    L'erreur bloque à ce niveau :

    End If
        'Set Plg = Range("TbBoxi").SpecialCells(xlCellTypeVisible)
        'Plg.Copy Workbooks(Fc).Sheets("Requête BO Stock").Range("A2")
    

    Il efface les données à ce niveau :

    With Workbooks("1- GV.xls").Sheets("Requête BO Stock").ListObjects(1)
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    End With 'Range("S2").FormulaR1C1 = "=RAND()"

    Je te remercie pour ton aide
    0
    1. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   1 588
       
      je n'ai pas tout compris.
      je me demande si tu ne pourrais pas faire ainsi:
      - au lieu de faire "on error resume next", faire "on error goto erreurfiltre"
      - et ajouter quelque part:
      erreurfiltre:
           on error goto 0

      de cette façon, au lieu de continuer comme si de rien était en cas d'erreur, le code va continuer à s'exécuter à l'endroit que tu choisis. tu devras peut-être déplacer certaines parties de code, par exemple déplacer avant le filtrage tout le code que tu veux toujours exécuter.
      0
    2. Ines2412
       
      Bonjour,

      Je viens de tester ça à l'air de fonctionner!!

      Merci beaucoup!!!
      0
    3. Ines2412
       
      En fait j'ai été trop hative, cela fonctionne pour le premier fichier mais pas le suivant:

      J'ai l'erreur suivante

      "Erreur d'execution 1004" Pas de cellules correspondantes et en effet il n'y a rien à copier

      C'est la ligne ci dessous qui bloque :
      Set Plg = Range("TbBoxi").SpecialCells(xlCellTypeVisible)

      J'ai retravaillé le code c'est le suivant :

      Sub OuvrFich()
      Application.ScreenUpdating = False
      Dim Dir As String
      Dim c As Range, Plg As Range
      Dim Ag As String, Dossier As String, Fc As String
      Dim DerLgAg As Integer, j As Byte

      'Boucle pour choisir le fichier Ag à traiter
      'nb de fichiers à traiter
      NbFc = Range("TbFic").Rows.Count
      For x = 3 To NbFc + 3
      Dir = "DAE"
      Ag = Sheets("Table de concordance").Range("B" & x).Offset(0, -1).Value
      Fc = Sheets("Table de concordance").Range("B" & x).Offset(0, 1).Value
      Dossier = Sheets("Table de concordance").Range("B" & x).Value
      Workbooks.Open ChemApp & "\" & Dossier & "\" & Fc
      Set WbFc = Workbooks(Fc)


      'on rappatrie les données de boxi sur
      WbApp.Activate
      'on met les filtres
      Sheets("Stocks").Activate
      Set Plg = Range("TbBoxi")

      'on filtre sur l'agence à traiter - GV
      On Error Resume Next 'Erreur si aucun filtre présent
      Range("TbBoxi#Headers").Select
      ActiveSheet.ShowAllData 'suppression des filtres
      Plg.AutoFilter Field:=2, Criteria1:=Ag, Operator:=xlAnd
      Plg.AutoFilter Field:=5, Criteria1:="Attribution "
      Plg.AutoFilter Field:=14, Criteria1:="Oui"
      On Error GoTo 0 'annule la gestion d'erreur

      'On rapattrie les données du fichier GV - Requête BO stock -
      'On vide le fichier "1- GV.xls" de versement onglet Requete Bo Stock 'TbRqBo
      With Workbooks("1- GV.xls").Sheets("Requête BO Stock").ListObjects(1)
      If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete

      End With 'Range("S2").FormulaR1C1 = "=RAND()"

      Workbooks("1- GV.xls").Sheets("Requête BO Stock").Range("TbRqBo[Fonction aléa]").Cells(1, 1).FormulaR1C1 = "=RAND()"
      On Error GoTo erreurfiltre
      Set Plg = Range("TbBoxi").SpecialCells(xlCellTypeVisible)
      Plg.Copy Workbooks(Fc).Sheets("Requête BO Stock").Range("A2")


      erreurfiltre:
      On Error GoTo 0

      Next
      0
      1. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   1 588 > Ines2412
         
        tu as l'erreur malgré le "on error"?
        0