Macro pour copier plusieurs onglets de plusieurs feuilles [Résolu/Fermé]

Signaler
Messages postés
40
Date d'inscription
mercredi 23 mars 2016
Statut
Membre
Dernière intervention
6 septembre 2016
-
Messages postés
40
Date d'inscription
mercredi 23 mars 2016
Statut
Membre
Dernière intervention
6 septembre 2016
-
Bonjour,
j'ai une macro que j'ai besoin d'améliorer car je viens de me rendre compte que certains classeurs avaient plusieurs onglets.

du coup je voudrais intégrer dans le code le fait de remonter tous les onglets du classeurs tant que la cellule A4 n'est pas vide.

Sub syntèseClasseurs()
Dim ClasseurRecap As String, ClassImp As String, NomFeuilleImp As String, DerLigRecap As Long, DerLigImp As Long, Pays As Variant, Code As String

Rows("3:" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Delete

' Détermination du classeur récapitulatif
ClasseurRecap = ThisWorkbook.Name
DerLigRecap = Cells(Rows.Count, 2).End(xlUp).Row

' Détermination DernièreLigne
If DerLigRecap <= 2 Then
DerLigRecap = 3
End If

'Set maitre = ActiveWorkbook
Repertoire = ThisWorkbook.Path
ClassImp = Dir(Repertoire & "\*.xls") ' premier fichier
Do While ClassImp <> ""
If ClassImp <> ThisWorkbook.Name Then
Workbooks.Open Filename:=Repertoire & "\" & ClassImp
NomFeuilleImp = Workbooks(ClassImp).ActiveSheet.Name
DerLigImp = Workbooks(ClassImp).Worksheets(NomFeuilleImp).Cells(Rows.Count, 2).End(xlUp).Row
Rows("4:" & DerLigImp).Copy
Pays = Range("A1").Value
Windows(ClasseurRecap).Activate
Rows(DerLigRecap).Select
ActiveSheet.Paste
Range("AA" & DerLigRecap & ":AA" & DerLigRecap + DerLigImp - 4) = Pays
Application.CutCopyMode = False
Windows(ClassImp).Close False
With Worksheets("Table").Range("A1:A" & Worksheets("Table").Cells(Rows.Count, 1).Row)
Set c = .Find(Pays, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
ActiveSheet.Range("AB" & DerLigRecap & ":AB" & DerLigRecap + DerLigImp - 4).Value = c.Offset(0, 1)
ActiveSheet.Range("AC" & DerLigRecap & ":AC" & DerLigRecap + DerLigImp - 4).Value = c.Offset(0, 2)
End If
End With
DerLigRecap = DerLigRecap + DerLigImp - 3
End If
ClassImp = Dir ' fichier suivant
Loop

Range(Cells(3, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 30)).Style = "Style 1"
Columns("A:AD").AutoFit
Rows("1:" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFit

For Each cell In Range("B3:B" & Cells(Rows.Count, 2).End(xlUp).Row)
If cell = "TIT" Then
Code = "G2 TIT"
ElseIf cell = "VI" Then
Code = "G3 VI"
ElseIf cell = "CTR" Then
Code = "G4 CTR"
ElseIf cell = "ADL" Then
Code = "G5 ADL"
Else: Code = ""
End If
Range("AD" & cell.Row) = Code
Next cell

End Sub


merci à ceux qui pourront m'aider
http://www.cjoint.com/c/FDbnFQj2Kxi


1 réponse

Messages postés
14934
Date d'inscription
lundi 18 octobre 2004
Statut
Contributeur
Dernière intervention
24 juin 2020
4 193
Bonjour,

Je te propose la modification ainsi :
Sub syntèseClasseurs()
Dim ClasseurRecap As String, ClassImp As String, NomFeuilleImp As String, DerLigRecap As Long, DerLigImp As Long, Pays As Variant, Code As String
Dim feu As Worksheet, wcr As Worksheet
Rows("3:" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Delete

' Détermination du classeur récapitulatif
ClasseurRecap = ThisWorkbook.Name
DerLigRecap = Cells(Rows.Count, 2).End(xlUp).Row
Set wcr = ThisWorkbook.ActiveSheet
' Détermination DernièreLigne
If DerLigRecap <= 2 Then
DerLigRecap = 3
End If

  'Set maitre = ActiveWorkbook
  Repertoire = ThisWorkbook.Path
  ClassImp = Dir(Repertoire & "\*.xls")  ' premier fichier
    While ClassImp <> ""
      If ClassImp <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=Repertoire & "\" & ClassImp
          For Each feu In ActiveWorkbook
             If feu.Range("A4").Value <> "" Then
                DerLigImp = feu.Cells(Rows.Count, 2).End(xlUp).Row
                    Pays = Range("A1").Value
                    Rows("4:" & DerLigImp).Copy
                        wcr.Rows(DerLigRecap).Paste
                            wcr.Range("AA" & DerLigRecap & ":AA" & DerLigRecap + DerLigImp - 4) = Pays
                    DerLigRecap = DerLigRecap + DerLigImp - 3
             End If
          Next feu
        Windows(ClassImp).Close False
          With Worksheets("Table").Range("A1:A" & Worksheets("Table").Cells(Rows.Count, 1).Row)
              Set c = .Find(Pays, LookIn:=xlValues, lookat:=xlWhole)
                  If Not c Is Nothing Then
                      ActiveSheet.Range("AB" & DerLigRecap & ":AB" & DerLigRecap + DerLigImp - 4).Value = c.Offset(0, 1)
                      ActiveSheet.Range("AC" & DerLigRecap & ":AC" & DerLigRecap + DerLigImp - 4).Value = c.Offset(0, 2)
                  End If
          End With
      End If
    ClassImp = Dir ' fichier suivant
  Wend
  Application.CutCopyMode = False
  
Range(Cells(3, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 30)).Style = "Style 1"
Columns("A:AD").AutoFit
Rows("1:" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFit

For Each cell In Range("B3:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    If cell = "TIT" Then
        Code = "G2 TIT"
    ElseIf cell = "VI" Then
        Code = "G3 VI"
    ElseIf cell = "CTR" Then
        Code = "G4 CTR"
    ElseIf cell = "ADL" Then
        Code = "G5 ADL"
    Else: Code = ""
    End If
        Range("AD" & cell.Row) = Code
Next cell

End Sub

Messages postés
40
Date d'inscription
mercredi 23 mars 2016
Statut
Membre
Dernière intervention
6 septembre 2016

bonjour merci beaucoup pour la réponse.

désolée du retard de réponse mais je ne reçois pas les notifications.