Macro pour copier plusieurs onglets de plusieurs feuilles

Résolu

cooljuly Messages postés 40 Date d'inscription Statut Membre Dernière intervention -
cooljuly Messages postés 40 Date d'inscription Statut Membre Dernière intervention - 11 avril 2016 à 14:13

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

Afficher la suite

A voir également:

Macro pour copier plusieurs onglets de plusieurs feuilles
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Comment faire un livret avec des feuilles a4 - Guide
Regrouper plusieurs feuilles excel en une seule - Guide
Comment copier une vidéo youtube - Guide
Super copier - Télécharger - Gestion de fichiers

1 réponse

Réponse 1 / 1

gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention 4 725

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

cooljuly Messages postés 40 Date d'inscription Statut Membre Dernière intervention

bonjour merci beaucoup pour la réponse.

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

Discussions similaires

dessin avec symbole clavier

Votre réponse

Discussions similaires