XL 2016 Si colonne=0 alors copier coller ligne (plusieurs onglets)

lhbt78

XLDnaute Nouveau
Bonjour à tous,

Je vais essayer d'être le plus explicite possible.
J'ai un fichier excel avec plusieurs onglets (CP;CE1;CE2;CM1;CM2)
Chaque onglet des classes est consitué de la même manière.
Colonne A : la classe
Colonne B : Nom de l'élève
Colonne C : Prénom
Colonne D : Matière
Colonne E : Nom du devoir
Colonne F : Nom du professeur
Colonne G : la Date
Colonne H : la note

J'ai un dernier onglet intitulé "RECAP".
J'aimerais savoir s'il est possible (macro ou formule) de copier coller dans cet onglet les lignes des colonnes A;B;C;D;E dont toutes les notes de chaque onglet sont égales à 0.

Je vous en remercie par avance.
 

shinozak

XLDnaute Occasionnel
Bonjour,

VB:
Sub test()
y = Sheets("RECAP").Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 1 To Sheets.Count - 1
If Sheets(i).Name = "RECAP" Then i = i + 1
        For x = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row
            If Sheets(i).Range("H" & x) = 0 Then
               Sheets("RECAP").Range("A" & y & ":E" & y).Value = Sheets(i).Range("A" & x & ":E" & x).Value
               y = y + 1
           End If
        Next x
Next i
End Sub

Je te conseil d'attendre d'autres réponses, il y a beaucoup mieux à faire avec des uBound ou des dictionnaires.
 

lhbt78

XLDnaute Nouveau
Bonjour,

@shinozak ton code vba fonctionne parfaitement, cependant ma hiérarchie m'a demandé de rajouter un onglet, ce qui a pour cause la continuation de la boucle. Comment pourrait-on exprimer un arrêt de la boucle à l'onglet CM2 ?​

@Phil69970, désolé de ne pas avoir mis de fichier, je me suis fais incendier la dernière fois que j'en ai mis un... , ton code VBA fonctionne cependant il me copie colle également les colonnes F et G , et même souci pour l'arrêt de la boucle​

 

fanch55

XLDnaute Accro
Bonjour à tous,
En partant du principe que chaque table a une ligne d'entête,
code à mettre dans celui de la feuille Recap :
VB:
Sub Recap()
Dim Sh As Worksheet
Const Liste_Onglets = ";CP;CE1;CE2;CM1;CM2;"

    Application.ScreenUpdating = False

    Me.Activate
    Me.Rows("2:" & Me.Cells(Me.Rows.Count, "A").End(xlUp).Row + 1).Clear
    If Me.AutoFilterMode Then Me.Columns.AutoFilter
    
    For Each Sh In ThisWorkbook.Worksheets
        If InStr(1, Liste_Onglets, ";" & Sh.Name & ";", vbTextCompare) Then
            L = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row + 1
            If Sh.AutoFilterMode Then Sh.Columns.AutoFilter
            Sh.Columns("H").AutoFilter Field:=1, Criteria1:="0"
            N = Sh.Columns("A:E").SpecialCells(xlCellTypeVisible).Rows.Count
            If Sh.Columns("A:E").SpecialCells(xlCellTypeVisible).Rows.Count > 1 _
            Then Sh.Range("A2:E" & Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Me.Rows(L)
            Sh.Columns.AutoFilter
        End If
    Next
End Sub
 

fanch55

XLDnaute Accro
Ou une autre variante :
VB:
Sub TestAdo()
Dim Sh As Worksheet
Dim Select_String As String
Dim Sql_Driver  As String
Const Liste_Onglets = ";CP;CE1;CE2;CM1;CM2;"
    
    Sql_Driver = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
                 "DBQ=" & ThisWorkbook.FullName & ";READONLY=FALSE"

    Application.ScreenUpdating = False
    
    For Each Sh In ThisWorkbook.Worksheets
        If InStr(1, Liste_Onglets, ";" & Sh.Name & ";", vbTextCompare) Then
            If Select_String <> "" Then Select_String = Select_String & " union "
            Select_String = Select_String & _
            " Select Classe,  Nom, Prenom,  Matiere, Devoir " & _
            "     From [" & Sh.Name & "$] Where Note=0 "
        End If
    Next
    
    If Select_String <> "" Then
        On Error Resume Next
        Me.Activate
        Me.Rows("2:" & Me.Cells(Me.Rows.Count, "A").End(xlUp).Row + 1).Clear
        Set Source_Folder = CreateObject("ADODB.Connection")
            Source_Folder.Open Sql_Driver
            Set Source_Filtre = CreateObject("ADODB.Recordset")
                Source_Filtre.ActiveConnection = Source_Folder
                Source_Filtre.Open Select_String
                Select Case True
                    Case Err <> 0: MsgBox "Erreur " & Err().Number & vbLf & Err().Description
                    Case Source_Filtre.EOF
                    Case Else: Me.[A2].CopyFromRecordset Source_Filtre
                End Select
                Source_Filtre.Close
            Set Source_Filtre = Nothing
         Set Source_Folder = Nothing
    End If
    
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
291 667
Messages
1 916 973
Membres
179 500
dernier inscrit
oximo
Haut Bas