Consolidation de plusieurs onglets dans 1 feuille à l'exception de certain

bonjour

j'aurais besoin d'un petit coup de main

j'ai trouver ce code qui marche nickel pour consolider plusieurs onglet

le souci est le suivant : je souhaiterais consolider les onglets de 4 a10 uniquement

je tenter d'applique une for to mes ca bug

merci d'avance pour votre aide😊

Sub TableauFinal()

Dim sh As Worksheet, F As Worksheet

Set sh = Worksheets.Add
On Error Resume Next
Application.DisplayAlerts = False
Sheets("bd").Delete
Application.DisplayAlerts = True
sh.Name = "bd"

For Each F In Worksheets
If F.Name <> sh.Name Then
    If WorksheetFunction.CountA(F.UsedRange) <> 0 Then

With F

.Range(.Cells(1, 1), .Cells(DerLig(F), DerCol(F))).Copy _
sh.Cells(DerLig(sh) + 1, 1)

End With

    End If

        End If
Next

Set sh = Nothing: Set F = Nothing

End Sub

'--------------------------------------
Function DerLig(sh As Worksheet)
On Error Resume Next
DerLig = sh.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
End Function
'--------------------------------------
Function DerCol(sh As Worksheet)
On Error Resume Next
DerCol = sh.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
On Error GoTo 0
End Function

Bonjour Puro206

Peut-être comme ceci

Sub TableauFinal()
  Dim sh As Worksheet, F As Worksheet
  Dim ShtNo As String
  Set sh = Worksheets.Add
  On Error Resume Next
  Application.DisplayAlerts = False
  Sheets("bd").Delete
  Application.DisplayAlerts = True
  sh.Name = "bd"
  ' Liste des feuille à ne pas traiter
  ShtNo = "Machin,Truc,Bidule"
  ' Pour chaque feuille
  For Each F In Worksheets
    ' Si fait partie de la liste, on passe
    If InStr(1, ShtNo, F.Name) > 0 Then GoTo SuiteF
    ' Sinon
    If WorksheetFunction.CountA(F.UsedRange) <> 0 Then
      F.Range("A1:" & F.Cells(DerLig(F), DerCol(F)).Address).Copy _
          sh.Cells(DerLig(sh) + 1, 1)
    End If
SuiteF:
  Next
  Set sh = Nothing: Set F = Nothing
End Sub

A+

bruno bonjour et merci pour ta réactivité

malheureusement ca bug😫

Pyro206

Sérieux

Vous ne savez pas ce que veut dire "Goto"... et une étiquette...

Il faut remplacer Goto SuiteD par Goto SuiteF

A+

merci

oui effectivement désolé fatiguée au heureusement que les vacances débute ce soir 😁