Code ok en pas à pas mais pas via bouton

Le 06/08/2024 à 11:37

Bonjour à tous,

J'ai ce code qui fonctionne parfaitement en pas à pas via la touche F8 dans l'éditeur, mais qui ne fonctionne pas via bouton.

Le code se déroule mais les plages que je souhaite importer de la feuille cible ne s'importent pas, alors qu'en pas à pas oui... En fait, l'action "Copy" ne se fait pas visiblement.

Sub Import_XXXXX()

Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveWorkbook.UpdateLinks = xlUpdateLinksNever

Dim nblig As Integer, dlg As Integer
Dim dlg1 As Integer
Dim nblig1 As Integer
Dim reponse As Byte
Dim cell As Range

reponse = MsgBox("Le fichier Coverage Status XX est-il bien ouvert ?", vbYesNo)

If reponse = vbYes Then

dlg = Range("C" & Rows.Count).SpecialCells(xlCellTypeVisible).End(xlUp).Row
dlg1 = Range("H" & Rows.Count).End(xlUp).Row + 1

'------------------------------IMPORT LIGNES XXXX------------------------------------------------------

With Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165").Sheets("Carnet de commande ")
        .Activate
        .Range("$CL$9:$CL$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
    If ActiveSheet.Range("$CL$9:$CL$3000").SpecialCells(xlCellTypeVisible).Count = 1 Then
        MsgBox "Pas de commande SPARES ni KITS AIRBUS", vbExclamation

    Else:
    .Range("$BO$9:$BO$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="KITS AIRBUS"
        If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
        MsgBox "Pas de commande KITS AIRBUS", vbExclamation
        Else:
        On Error Resume Next
        .Range("$C$10:$E$" & dlg).SpecialCells(xlCellTypeVisible).Copy
        Workbooks("LOB RECHANGES").Activate
        Sheets("KITS AIRBUS").Cells(Rows.Count, 6).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        End If
    End If

'------------------------------IMPORT LIGNES XXXXX------------------------------------------------------

        .Range("$CL$9:$CL$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
    If ActiveSheet.Range("$CL$9:$CL$3000").SpecialCells(xlCellTypeVisible).Count = 1 Then
        MsgBox "Pas de commande RECHANGES ni KITS AIRBUS", vbExclamation

    Else:
    .Range("$BO$9:$BO$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="SPARES"
        If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
        MsgBox "Pas de commande SPARES", vbExclamation
        Else:
        Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165").Sheets("Carnet de commande ").Range("$C$10:$E$" & dlg).SpecialCells(xlCellTypeVisible).Copy
        Workbooks("LOB RECHANGES").Activate
        Sheets("RECHANGES").Cells(Rows.Count, 8).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        Call Refresh_Coverage1
        Call Figer_Coverage1
        End If
    End If

End With

MsgBox "Commanndes importées avec succés"

Else
MsgBox "Ouvrez-le avant d'exécuter la macro !"
End
Exit Sub
End If

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Merci à tous.

Le 06/08/2024 à 12:30

Bonjour,

Il me semble qu'après le premier import de lignes, on se retrouve sur le classeur "LOB RECHANGES", alors qu'il faudrait revenir sur le classeur "KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165".

Sub Import_XXXXX()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveWorkbook.UpdateLinks = xlUpdateLinksNever

    Dim nblig As Integer, dlg As Integer
    Dim dlg1 As Integer
    Dim nblig1 As Integer
    Dim reponse As Byte
    Dim cell As Range

    reponse = MsgBox("Le fichier Coverage Status XX est-il bien ouvert ?", vbYesNo)
    If reponse = vbYes Then
        dlg = Range("C" & Rows.Count).SpecialCells(xlCellTypeVisible).End(xlUp).Row
        dlg1 = Range("H" & Rows.Count).End(xlUp).Row + 1

        '------------------------------IMPORT LIGNES XXXX------------------------------------------------------

        With Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165").Sheets("Carnet de commande ")
            .Activate
            .Range("$CL$9:$CL$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
            If ActiveSheet.Range("$CL$9:$CL$3000").SpecialCells(xlCellTypeVisible).Count = 1 Then
                MsgBox "Pas de commande SPARES ni KITS AIRBUS", vbExclamation
            Else:
                .Range("$BO$9:$BO$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="KITS AIRBUS"
                If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
                    MsgBox "Pas de commande KITS AIRBUS", vbExclamation
                Else:
                    On Error Resume Next
                    .Range("$C$10:$E$" & dlg).SpecialCells(xlCellTypeVisible).Copy
                    Workbooks("LOB RECHANGES").Activate
                    Sheets("KITS AIRBUS").Cells(Rows.Count, 6).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                   On Error Goto 0
                End If
            End If
        End With

        '------------------------------IMPORT LIGNES XXXXX------------------------------------------------------
        With Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165")
            .Activate
            .Range("$CL$9:$CL$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
            If ActiveSheet.Range("$CL$9:$CL$3000").SpecialCells(xlCellTypeVisible).Count = 1 Then
                MsgBox "Pas de commande RECHANGES ni KITS AIRBUS", vbExclamation
            Else:
                .Range("$BO$9:$BO$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="SPARES"
                If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
                    MsgBox "Pas de commande SPARES", vbExclamation
                Else:
                    Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165").Sheets("Carnet de commande ").Range("$C$10:$E$" & dlg).SpecialCells(xlCellTypeVisible).Copy
                    Workbooks("LOB RECHANGES").Activate
                    Sheets("RECHANGES").Cells(Rows.Count, 8).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                    Call Refresh_Coverage1
                    Call Figer_Coverage1
                End If
            End If
        End With
        MsgBox "Commanndes importées avec succés"
    Else
        MsgBox "Ouvrez-le avant d'exécuter la macro !"
    End If

    Application.EnableEvents = True
End Sub

J'ai ajouté un "On Error Goto 0" pour que le programme continue au cas où il y aurait un problème lors de la première copie

Si vous Autre chose, si vous mettez un "Application.EnableEvents=False" au début, il vaut mieux mettre "Application.EnableEvents = True" avant le "Exit Sub"

Cdlt

Le 06/08/2024 à 13:21

J'ai modifié le code comme proposé. En fait la copie ne se fait toujours pas, même en mode "pas à pas" la ligne de code passe sans exécuter la copie des cellules.

Sub Import_NewOrderKITSAIB()

Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveWorkbook.UpdateLinks = xlUpdateLinksNever

Dim nblig As Integer, dlg As Integer
Dim dlg1 As Integer
Dim nblig1 As Integer
Dim reponse As Byte
Dim cell As Range

reponse = MsgBox("Le fichier Coverage Status SPARES est-il bien ouvert ?", vbYesNo)

If reponse = vbYes Then

Call EffacerTousLesFiltres
Call Open_CDC

dlg = Range("C" & Rows.Count).SpecialCells(xlCellTypeVisible).End(xlUp).Row
dlg1 = Range("H" & Rows.Count).End(xlUp).Row + 1

'------------------------------IMPORT LIGNES KITS AIRBUS------------------------------------------------------

With Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165").Sheets("Carnet de commande ")
        .Range("$CL$9:$CL$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
    If ActiveSheet.Range("$CL$9:$CL$3000").SpecialCells(xlCellTypeVisible).Count = 1 Then
        MsgBox "Pas de commande SPARES ni KITS AIRBUS", vbExclamation
    Else:
    .Range("$BO$9:$BO$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="KITS AIRBUS"
        If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
        MsgBox "Pas de commande KITS AIRBUS", vbExclamation
        Else:
        On Error Resume Next
        .Range("$C$10:$E$" & dlg).SpecialCells(xlCellTypeVisible).Copy
        Workbooks("LOB RECHANGES").Activate
        Sheets("KITS AIRBUS").Cells(Rows.Count, 6).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        On Error GoTo 0
        End If
    End If
End With

Call EffacerTousLesFiltres

'------------------------------IMPORT LIGNES SPARES------------------------------------------------------

With Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165").Sheets("Carnet de commande ")
        .Range("$CL$9:$CL$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
    If ActiveSheet.Range("$CL$9:$CL$3000").SpecialCells(xlCellTypeVisible).Count = 1 Then
        MsgBox "Pas de commande RECHANGES ni KITS AIRBUS", vbExclamation

    Else:
        .Range("$BO$9:$BO$" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="SPARES"
        If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
        MsgBox "Pas de commande SPARES", vbExclamation
        Else:
        On Error Resume Next
        .Range("$C$10:$E$" & dlg).SpecialCells(xlCellTypeVisible).Copy
        Workbooks("LOB RECHANGES").Activate
        Sheets("RECHANGES").Cells(Rows.Count, 8).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        On Error GoTo 0
        Call Refresh_Coverage1
        Call Figer_Coverage1
        End If
    End If
End With

Call EffacerTousLesFiltres
MsgBox "Commanndes importées avec succés"

Else
MsgBox "Ouvrez-le avant d'exécuter la macro !"
End
Exit Sub
End If

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
Le 06/08/2024 à 15:35

Sans fichier joint, à moins de tout reproduire à l'identique, ce n'est pas évident de voir où se situe le problème.

Pourquoi n'avez- vous pas recopié le code que j'avais mis? car je vois que vous n'avez pas tenu compte de ma dernière remarque:

Autre chose, si vous mettez un "Application.EnableEvents=False" au début, il vaut mieux mettre "Application.EnableEvents = True" avant le "Exit Sub"
Le 06/08/2024 à 15:50

Dans cette partie de code comme ceci ?

Else
MsgBox "Ouvrez-le avant d'exécuter la macro !"
End
Application.EnableEvents = True
Exit Sub
End If

Application.ScreenUpdating = True

End Sub
Le 06/08/2024 à 16:34

Bonjour,

Vous avez un peu tendance à brûler les étapes :

C'est :

With Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165")
   With .Sheets("Carnet de commande ")
            .Activate
            .Range ("$CL$9:$CL$")

Si vous ne voulez pas trop alourdir le code instanciez le WbkSrc

Set WbkSrc = Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165")
   With WbkSrc.Sheets("Carnet de commande ")
      .Activate
      .Range ("$CL$9:$CL$")

Bon... Epi : ActiveSheet Si vous l'instanciez également ce serait plus précis, parce que je parie que à chaque fois que vous écrivez Activesheet, si à la ligne précédente vous placez un MsgBox ActiveSheet.Name : Une fois sur 2 vous seriez surpris !

A+

Le 07/08/2024 à 09:51

Bonjour Galopin,

Un peu comme ceci ?

Set WbkSrc = Workbooks("KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165")
Set WbkSrd = Workbooks("LOB RECHANGES")
Set WbkSrE = ActiveSheet.Range("$CL$9:$CL$3000")
Set WbkSrF = ActiveSheet.Range("$BO$9:$BO$3000")

With WbkSrc.Sheets("Carnet de commande ")
        .Range("$CL$9:$CL" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=90, Criteria1:="TO BE ADDED"
    If WbkSrE.SpecialCells(xlCellTypeVisible).Count = 1 Then
        MsgBox "Pas de commande SPARES ni KITS AIRBUS", vbExclamation
    Else:
        .Range("$BO$9:$BO" & dlg).SpecialCells(xlCellTypeVisible).AutoFilter Field:=67, Criteria1:="KITS AIRBUS"
            If ActiveSheet.Range("$BO$9:$BO$3000").SpecialCells(xlCellTypeVisible).Rows.Count = 0 Then
            MsgBox "Pas de commande KITS AIRBUS", vbExclamation
            Else:
            On Error Resume Next
        .Range("$C$10:$E" & dlg).SpecialCells(xlCellTypeVisible).Copy
    End With
        With WbkSrd.Sheets("KITS AIRBUS")
            .Activate
            .Cells(Rows.Count, 6).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        On Error GoTo 0
        End With
            End With
Le 07/08/2024 à 10:25

Oui il y a l'idée mais et ActiveSheet tu la sors d'ou ?

remarque : Quand les déclarations sont bien faites : Pas besoin de activate...

Exemple : Crée 2 classeurs CTestA.xlsm et CTestB.xlsm

Dans CTestB.xlsm crée une deuxième feuille : "Feuil2"

Dans CTestB.xlsm pour l'instant on n'écrit pas et on le garde ouvert.

Dans CTestA.xlsm (Feuil1), entre ces valeurs dans la plage A1:B2 :

12
34

puis colle cette macro dans CTestA.xlsm.Module1

Sub Test()
Dim WkS As Workbook
Dim ShS As Worksheet
Dim WkC As Workbook
Dim ShC As Worksheet
Dim ShCC As Worksheet
   Set WkS = ThisWorkbook 'ThisWorkbook est le classeur qui contient les macros
   Set ShS = WkS.Worksheets("Feuil1")
   Set WkC = Workbooks("CTestB.xlsm")
   Set ShC = WkC.Worksheets("Feuil1")
   Set ShCC = WkC.Worksheets("Feuil2")
      With ShS
         .Range("A1:B1").Copy ShC.Range("A1")
         .Range("A2:B2").Copy ShCC.Range("A2")
      End With
End Sub

La copie est terminée : Aucune activation n'a été faite.

Cette expérience résume tous tes problèmes !

Cela n'aurait pas été bien différent avec un filtrage supplémentaire et une recherche de ligne !

A+

Rechercher des sujets similaires à "code pas via bouton"