Consolidation d'onglets

On veut consolider des onglets.

ConsolideOnglets.xls

Version1

Sub consolide_onglets()
  Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
  For s = 2 To Sheets.Count
     Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy _
       [A65000].End(xlUp).Offset(1, 0)
  Next s
  On Error Resume Next
  [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version2

Sub consolide_onglets2()
    Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
    For s = 2 To Sheets.Count
      nlig = Sheets(s).[A65000].End(xlUp).Row - 1
      ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
     [A65000].End(xlUp).Offset(1, 0).Resize(nlig, ncol).Value = _
     Sheets(s).[A2].Resize(nlig, ncol).Value
   Next s
   On Error Resume Next
   [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version3 (collage spécial)

Sub consolide_ongletsCollageSpecial()
   Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
   For s = 2 To Sheets.Count
     nlig = Sheets(s).[A65000].End(xlUp).Row - 1
     ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
     Sheets(s).[A2].Resize(nlig, ncol).Copy
     [A65000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
  Next s
  On Error Resume Next
  [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version4 (ajoute les noms des onglets dans une colonne)

Sub consolide_ongletsNomOnglet()
   Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
   For s = 2 To Sheets.Count
      nlig = Sheets(s).[A65000].End(xlUp).Row - 1
      ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
      [A65000].End(xlUp).Offset(1, ncol).Resize(nlig, 1).Value = Sheets(s).Name
      [A65000].End(xlUp).Offset(1, 0).Resize(nlig, ncol).Value = _
      Sheets(s).[A2].Resize(nlig, ncol).Value
   Next s
   On Error Resume Next
   [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version5

Sub consolide_ongletsNomOngletCouleur()
Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
For s = 2 To Sheets.Count
nlig = Sheets(s).[A65000].End(xlUp).Row - 1
ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
[A65000].End(xlUp).Offset(1, ncol).Resize(nlig, 1).Value = Sheets(s).Name
[A65000].End(xlUp).Offset(1, 0).Resize(nlig, ncol + 1).Interior.ColorIndex = _
Sheets(s).[A2].Interior.ColorIndex
[A65000].End(xlUp).Offset(1, 0).Resize(nlig, ncol).Value = _
Sheets(s).[A2].Resize(nlig, ncol).Value
Next s
On Error Resume Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub