Faire évoluer mon code

[SSIAP2]

Bonjour je viens vous demandé votre aide Svp .

j'utilise ce code qui me permet de chercher sur plusieur Feuil de mon classeur et de récupéré si la valeur est supérieure à 0 et de la copié dans ma page accueil certaine colone de cette ligne. cela fonctionne bien pour 4 colonne.

mon probleme c'est que je souhaite faire la meme chose mais avec 19 colonne et la j'ai un peut tous essayer et cela fonctionne plus c'est à dire selon ce que je change dans le code il me dit que cela ne fais pas partie de la sélection ou tous simplement aucune erreur mais rien n'est copié


voici ce code:

Private Sub CommandButton2_Click()
With Sheets("Accueil")
 
    Range("A5:S33").Select
    Selection.ClearContents
    Range("E26").Select

End With
  Dim Ws As Worksheet, Tbl() As Variant, C As Integer

    Application.ScreenUpdating = False
    
ReDim Tbl(1 To 5, 1 To 4)
C = 1
    For Each Ws In Worksheets
        If Left(Ws.Name, 3) = "BDD" Then
            With Ws
                For Each CEL In .Range("A4:A" & .Range("R65000").End(xlUp).Row)
                    If CEL > 0 Then
                        l = CEL.Row
                        Tbl(1, C) = .Range("A" & l).Value
                        Tbl(2, C) = .Range("B" & l).Value
                        Tbl(3, C) = .Range("C" & l).Value
                        Tbl(4, C) = .Range("D" & l).Value
                        Tbl(5, C) = .Range("E" & l).Value
                        Tbl(6, C) = .Range("F" & l).Value '<== à partir d'ici cela ne fonctionne plus
                        Tbl(7, C) = .Range("G" & l).Value
                        Tbl(8, C) = .Range("H" & l).Value
                        Tbl(9, C) = .Range("I" & l).Value
                        Tbl(10, C) = .Range("J" & l).Value
                       Tbl(11, C) = .Range("K" & l).Value
                        Tbl(12, C) = .Range("L" & l).Value
                        Tbl(13, C) = .Range("M" & l).Value
                        Tbl(14, C) = .Range("N" & l).Value
                        Tbl(15, C) = .Range("O" & l).Value
                        Tbl(16, C) = .Range("P" & l).Value
                        Tbl(17, C) = .Range("Q" & l).Value
                        Tbl(18, C) = .Range("R" & l).Value
                       Tbl(19, C) = .Range("S" & l).Value
                      
                        C = C + 1
                        ReDim Preserve Tbl(1 To 5, 1 To C)
                    End If
                Next CEL
            End With


        End If
    Next Ws
    
    Tbl = Application.Transpose(Tbl)
    
        With Sheets("Accueil")
        LI = .Range("A600").End(xlUp).Row + 1
            .Cells(LI, 1).Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl
    End With
''deproteg.ProtegeTout
    Application.ScreenUpdating = True
End Sub

et merci pour votre aide précieuse

 

[WDAndCo]

Re : Faire évoluer mon code

Bonjour le Forum

ReDim Tbl(1 To 19, 1 To 4)

Peut être ?

 

[SSIAP2]

Re : Faire évoluer mon code

Bonjour WDAndCo et merci pour ton aide donc j'ai essayer ta solution mais cela ne donne rien pas erreur mais il ne copie pas j'avais egalement essayer de monté de 19 unité par apport au code initiale mais rien du tous

 

[kjin]

Re : Faire évoluer mon code

bonjour,
SSIAP2, sans fichier c'est coton non ?!

Dim Ws As Worksheet, Tbl() As Variant, l As Long, x As Long
For Each Ws In Worksheets
    If Left(Ws.Name, 3) = "BDD" Then
        With Ws
            For Each Cel In .Range("A4:A" & .Range("A65000").End(xlUp).Row)
                If Cel > 0 Then
                    l = Cel.Row
                    x = x + 1
                    ReDim Preserve Tbl(1 To 19, 1 To x)
                    For i = 1 To 19
                        Tbl(i, x) = .Cells(l, i).Value
                    Next
                End If
            Next Cel
        End With
    End If
Next Ws

A+
kjin

 

[SSIAP2]

Re : Faire évoluer mon code

bonjour kjin ta methode semble fonctionnée juste un peit soucis il me reprend à chaque ligne les entêtes des colonne sinon sa à l'air de fonctionné je me penche dessus egalement pour voir si mes conaissance me permet de résoudre ce soucis merci à toi

 

[SSIAP2]

Re : Faire évoluer mon code

Re bonjour donc pour le probleme d'entête j'ai cerné le probleme certaine de mes Feuilles ont pas d'information donc il remonte jusqu'a l'entête et la copie comme si c'etait une ligne d'information peut t'on donc limité la recherche uniquement dans une zone donnée svp sinon tous le reste fonctionne bien merci

 

[SSIAP2]

Re : Faire évoluer mon code

Re la prochaine fois je réflechirais plus je crois que j'ai trouvée sa à l'air de fonctionnée j'ai ajouté +1 au code

Dim Ws As Worksheet, Tbl() As Variant, l As Long, x As Long
For Each Ws In Worksheets
    If Left(Ws.Name, 3) = "BDD" Then
        With Ws
            For Each Cel In .Range("A4:A" & .Range("A65000").End(xlUp).Row[COLOR="Red"]+1[/COLOR])
                If Cel > 0 Then
                    l = Cel.Row
                    x = x + 1
                    ReDim Preserve Tbl(1 To 19, 1 To x)
                    For i = 1 To 19
                        Tbl(i, x) = .Cells(l, i).Value
                    Next
                End If
            Next Cel
        End With
    End If
Next Ws

voilà je vais testé sa merci à bientot

 

[SSIAP2]

Re : Faire évoluer mon code

Re à tous donc mon probleme est en partis résolue je cherche désormais pour finir que ma zone copié ne se face pas à partir de la colonne A4 mais U4 quelqu'un aurais t'il une idée svp merci

 

[SSIAP2]

Re : Faire évoluer mon code

Solution trouvée une fois de plus alors que je cherchais depuis deux jour à faire tous cela pour mon dernier probléme il sufisais de mettre le nombre de colonne ici

With Sheets("Accueil")
 
    Range("A5:S1000").Select
    Selection.ClearContents
    Range("E26").Select

End With
  Dim Ws As Worksheet, Tbl() As Variant, l As Long, x As Long
For Each Ws In Worksheets
    If Left(Ws.Name, 3) = "BDD" Then
        With Ws
            For Each Cel In .Range("A4:A" & .Range("A65000").End(xlUp).Row + 1)
                If Cel > 0 Then
                    l = Cel.Row
                    x = x + 1
                    ReDim Preserve Tbl(1 To 4, 1 To x)
                    For I = 1 To 4
                        Tbl(I, x) = .Cells(l, I).Value
                    Next
                End If
            Next Cel
        End With
    End If
Next Ws
    
    Tbl = Application.Transpose(Tbl)
    
        With Sheets("Accueil")
        LI = .Range("[COLOR="red"]U600[/COLOR]").End(xlUp).Row + 1
            .Cells(LI, [COLOR="Red"]21[/COLOR]).Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl
    End With
''deproteg.ProtegeTout
    Application.ScreenUpdating = True

Voilà donc du coup j'ai répondu moi même à mes propre question peut être sa serviras un jour à quelqu'un bonne journée