XL 2016 modification de code vba

Seddiki_adz

XLDnaute Impliqué
comment modifier ce code vba si je veut juste consolider des onglets définie par leur nom
Sub Consolider()
Dim lig As Long, w As Worksheet, h As Long
Feuil1.Activate 'CodeName de "Consolidation Synthèse"
Application.ScreenUpdating = False 'fige l'écran
Rows("5:" & Rows.Count).Delete 'vidage
lig = 5 '1ère ligne à remplir
For Each w In Worksheets
If w.Name <> ActiveSheet.Name Then
h = w.Cells(Rows.Count, 2).End(xlUp).Row - 4
If h > 0 Then
w.[5:5].Resize(h).Copy Cells(lig, 1)
lig = lig + h
End If
End If
Next
If lig = 5 Then Exit Sub 'si aucun nom
With [5:5].Resize(lig - 5)
.Sort [B5], Header:=xlNo 'tri sur colonne B
'---épuration---
.Columns(2).Replace " ", "", LookAt:=xlWhole
On Error Resume Next
.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Merci
 
Solution
j'ai ajouter un onglet dans ce fichier et je ne veut pas consolider avec les autre onglets
à tester, je n'ai rajouté qu'une condition pour ne pas prendre en compte aussi la feuille que tu as ajouté (feuil1)
VB:
Option Explicit

Sub Consolider()
Dim lig As Long, w As Worksheet, h As Long
Feuil1.Activate 'CodeName de "Consolidation Synthèse"
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'évite les invites éventuelles (liaisons)
Rows("5:" & Rows.Count).Delete 'vidage
lig = 5 '1ère ligne à remplir
For Each w In Worksheets
  If w.Name <> ActiveSheet.Name And w.Name <> "feuil1" Then ' ajout condition non feuil1
    h = w.Cells(Rows.Count, 1).End(xlUp).Row - 4
    If h > 0 Then...

cp4

XLDnaute Barbatruc
Bonjour,

Sans fichier difficile de t'aider. Voici un lien où tu trouveras surement ton bonheur LIEN
Démo pour éditer ton code afin qu'il soit mieux lisible
Balise de code.gif

A+
 

Seddiki_adz

XLDnaute Impliqué
Je n'ai rien compris. Ni fichier, ni explications, je ne suis pas devin.
ce code vba consolider toutes les onglets et je modifier pour 3 onglet
 

Pièces jointes

  • Consolidation(2).xls
    331 KB · Affichages: 2
Dernière édition:

cp4

XLDnaute Barbatruc
ce code vba consolider toutes les onglets et je modifier pour 3 onglet
Ce n'est pas en me montrant des exemples que je vais comprendre ta problématique.
Il faut joindre ton fichier et des explications ou mieux le résultat attendu du code.
En effet, sur le fichier joint le code boucle sur toute les feuilles sauf la feuille active.

A+
 

Seddiki_adz

XLDnaute Impliqué
Ce n'est pas en me montrant des exemples que je vais comprendre ta problématique.
Il faut joindre ton fichier et des explications ou mieux le résultat attendu du code.
En effet, sur le fichier joint le code boucle sur toute les feuilles sauf la feuille active.

A+
j'ai ajouter un onglet dans ce fichier et je ne veut pas consolider avec les autre onglets
 

Pièces jointes

  • Consolidation(2).xls
    311 KB · Affichages: 2
  • 15555.png
    15555.png
    26.8 KB · Affichages: 25

cp4

XLDnaute Barbatruc
j'ai ajouter un onglet dans ce fichier et je ne veut pas consolider avec les autre onglets
à tester, je n'ai rajouté qu'une condition pour ne pas prendre en compte aussi la feuille que tu as ajouté (feuil1)
VB:
Option Explicit

Sub Consolider()
Dim lig As Long, w As Worksheet, h As Long
Feuil1.Activate 'CodeName de "Consolidation Synthèse"
Application.ScreenUpdating = False 'fige l'écran
Application.DisplayAlerts = False 'évite les invites éventuelles (liaisons)
Rows("5:" & Rows.Count).Delete 'vidage
lig = 5 '1ère ligne à remplir
For Each w In Worksheets
  If w.Name <> ActiveSheet.Name And w.Name <> "feuil1" Then ' ajout condition non feuil1
    h = w.Cells(Rows.Count, 1).End(xlUp).Row - 4
    If h > 0 Then
      w.[5:5].Resize(h).Copy Rows(lig) 'pour les formats
      Rows(lig).Resize(h, 13) = w.[5:5].Resize(h, 13).Value 'valeurs colonnes A:M
      lig = lig + h
    End If
  End If
Next
If lig = 5 Then Exit Sub 'si aucun nom
With [5:5].Resize(lig - 5)
  .Sort [B5], Header:=xlNo 'tri sur colonne B
  '---épuration---
  .Columns(1).Replace " ", "", LookAt:=xlWhole
  On Error Resume Next
  .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 949
Membres
101 852
dernier inscrit
dthi16088