Sujet Précédent Sujet Suivant

Macro pour copier plusieurs onglets de plusieurs feuilles

Résolu/Fermé
cooljuly Messages postés 40 Date d'inscription mercredi 23 mars 2016 Statut Membre Dernière intervention 6 septembre 2016 - 1 avril 2016 à 15:32
cooljuly Messages postés 40 Date d'inscription mercredi 23 mars 2016 Statut Membre Dernière intervention 6 septembre 2016 - 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


A voir également:

1 réponse

Réponse 1 / 1
gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 684
1 avril 2016 à 17:30
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

0
cooljuly Messages postés 40 Date d'inscription mercredi 23 mars 2016 Statut Membre Dernière intervention 6 septembre 2016
11 avril 2016 à 14:13
bonjour merci beaucoup pour la réponse.

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

Discussions similaires

Dessiner avec son clavier et avec des lettres
JSS -
Polodu33 -

78 réponses