Copier plusieurs onglats dans un seul

[sonskriverez]

Bonsoir le forum,

J'ai dans une feuille 25 onglets et je voudrai en vba pourvoir copier le contenu de chaque onglet dans un onglet "recap".

merci de votre aide

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Bonsoir

Utilsies le moteur de recherche du forum

Sujet déjà traité

Ou regardes en bas de ton post [Discussions similaires]

 

[sonskriverez]

Re : Copier plusieurs onglats dans un seul

Bonsoir Staple1600,

j'ai bien fais une recherche sans trouver et j'ai regardé les liens sans avoir de réponses à mon pbl, mais peut-être ai-je mal cherché.

Je recommence

merci de ton conseil

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Re


Je vois un début de solution dans ce post pourtant

https://www.excel-downloads.com/threads/copier-plusieurs-sheets-dun-classeur-dans-un-seul.9438/

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Re



Et dans celui-là aussi
https://www.excel-downloads.com/threads/regrouper-fichiers-excel-avec-les-memes-colonnes.82129/

 

[sonskriverez]

Re : Copier plusieurs onglats dans un seul

JM,

J'ai essayé ce code :

For i = 1 To Workbooks("plan.xls").Sheets.Count
.Sheets.Add.Move after:=.Sheets(.Sheets.Count)

la boucle FOR me donne 27 ce qui est mon nombre d'onglet dans mon classeur.
la 2 éme ligne me rajoute un new onglet

Pour l'instant c'est bon, mais je voudrais copier le contenu du premier onglet dans le nouveau et le contenu de second à la suite et cela jusqu'au 27.

Merci de ton aide

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Re


Tu as regardé mon deuxième lien

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Re



Je te laisse tester et adapter de code "ready-made"

[COLOR=blue]Sub[/COLOR] CopyUsedRangeValues() 
     'Auteur: Anne Troy
    [COLOR=blue]Dim[/COLOR] sh [COLOR=blue]As[/COLOR] Worksheet 
    [COLOR=blue]Dim[/COLOR] DestSh [COLOR=blue]As[/COLOR] Worksheet 
    [COLOR=blue]Dim[/COLOR] Last [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR] 
     
    [COLOR=blue]If[/COLOR] SheetExists("Master") = [COLOR=blue]True[/COLOR] [COLOR=blue]Then[/COLOR] 
        MsgBox "A worksheet called Master already exists" 
        Exit [COLOR=blue]Sub[/COLOR] 
    [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
    Application.ScreenUpdating = [COLOR=blue]False[/COLOR] 
    [COLOR=blue]Set[/COLOR] DestSh = Worksheets.Add 
    DestSh.Name = "Master" 
    [COLOR=blue]For Each[/COLOR] sh [COLOR=blue]In[/COLOR] ThisWorkbook.Worksheets 
        [COLOR=blue]If[/COLOR] sh.Name <> DestSh.Name [COLOR=blue]Then[/COLOR] 
            [COLOR=blue]If[/COLOR] sh.UsedRange.Count > 1 [COLOR=blue]Then[/COLOR] 
                Last = LastRow(DestSh) 
                [COLOR=blue]With[/COLOR] sh.UsedRange 
                    DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _ 
                    .Columns.Count).Value = .Value 
                [COLOR=blue]End With[/COLOR] 
            [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
         
    [COLOR=blue]Next[/COLOR] 
    Application.ScreenUpdating = [COLOR=blue]True[/COLOR] 
[COLOR=blue]End Sub[/COLOR] 
 
[COLOR=blue]Function[/COLOR] LastRow(sh [COLOR=blue]As[/COLOR] Worksheet) 
    [COLOR=blue]On Error Resume Next[/COLOR] 
    LastRow = sh.Cells.Find(What:="*", _ 
    After:=sh.Range("A1"), _ 
    Lookat:=xlPart, _ 
    LookIn:=xlFormulas, _ 
    SearchOrder:=xlByRows, _ 
    SearchDirection:=xlPrevious, _ 
    MatchCase:=[COLOR=blue]False[/COLOR]).Row 
    [COLOR=blue]On Error Goto[/COLOR] 0 
[COLOR=blue]End Function[/COLOR]

[COLOR=blue]Function[/COLOR] Lastcol(sh [COLOR=blue]As[/COLOR] Worksheet) 
     
    [COLOR=blue]On Error Resume Next[/COLOR] 
    Lastcol = sh.Cells.Find(What:="*", _ 
    After:=sh.Range("A1"), _ 
    Lookat:=xlPart, _ 
    LookIn:=xlFormulas, _ 
    SearchOrder:=xlByColumns, _ 
    SearchDirection:=xlPrevious, _ 
    MatchCase:=[COLOR=blue]False[/COLOR]).Column 
    [COLOR=blue]On Error Goto[/COLOR] 0 
[COLOR=blue]End Function[/COLOR]

[COLOR=blue]Function[/COLOR] SheetExists(SName [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], _ 
    Optional [COLOR=blue]ByVal[/COLOR] WB [COLOR=blue]As[/COLOR] Workbook) [COLOR=blue]As[/COLOR] [COLOR=blue]Boolean[/COLOR] 
     
    [COLOR=blue]On Error Resume Next[/COLOR] 
    [COLOR=blue]If[/COLOR] WB [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] [COLOR=blue]Set[/COLOR] WB = ThisWorkbook 
    SheetExists = [COLOR=blue]CBool[/COLOR](Len(Sheets(SName).Name)) 
[COLOR=blue]End Function
[COLOR=Black]

[/COLOR]
[/COLOR]

 

[sonskriverez]

Re : Copier plusieurs onglats dans un seul

excuse j'avais pas vu le deuxieme

j'ai regardé l'exemple, ca colle bien à mon besoin mais comment faire pour ne pas copier les titres.

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Re

en modifiant ceci non?

After:=sh.Range("A1"), _

 

[Cousinhub]

Re : Copier plusieurs onglats dans un seul

Bonsoir, stapple, sonskri...

stapple, une autre solution pour éviter de recopier les titres (en rouge, les modifs) :

Sub CopyUsedRangeValues()
     'Auteur: Anne Troy
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    [COLOR="Red"]Dim Titre As Boolean[/COLOR]
    
    If SheetExists("Master") = True Then
        MsgBox "A worksheet called Master already exists"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            [COLOR="Red"]If Not Titre Then DestSh.[A1] = sh.[A1]: Titre = True[/COLOR]
            If sh.UsedRange.Count > 1 Then
                Last = LastRow(DestSh)
                [COLOR="Red"]With sh.UsedRange.Resize(sh.UsedRange.Rows.Count - 1).Offset(1)[/COLOR]
                    DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
                    .Columns.Count).Value = .Value
                End With
            End If
        End If
         
    Next
    Application.ScreenUpdating = True
End Sub

En supposant qu'il n'y a qu'une ligne, sinon, pour copier les titres sur la nouvelle feuille, il faudra modifier :

[COLOR="Red"]If Not Titre Then DestSh.[A1] = sh.[A1]: Titre = True[/COLOR]

si j'ai bien suivi...(mais après tant de temps sans Excel, les neurones ne sont peut-être pas en phase...😀)

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Bonsoir bhbh


Un neurone qui un jour a connu Excel et VBA est armé pour la vie (lol)

 

[Cousinhub]

Re : Copier plusieurs onglats dans un seul

Re-, j'avais raison :

En supposant qu'il n'y a qu'une ligne

je voulais bien sûr dire "qu'une colonne"

Défaut de connexion entre les 2 neurones restantes 😱

 

[Staple1600]

Re : Copier plusieurs onglats dans un seul

Re




J'ai vu sur le forum un jour un code plus succinct que celui-ci

Impossible de remettre la main-dessus

Tu n'aurais pas ça en stock par hasard?

 

[sonskriverez]

Re : Copier plusieurs onglats dans un seul

Bonjour, stapple, bhbh...

Hier soir j'ai laché l'affaire.... et reprise ce matin à l'aube

Le code modifié de bhbh fonctionne parfaitement sur l'ensemble de mes onglets, j'ai juste rajouter , pour ne pas inclure cette sheet.

If sh.Name = "tools" Then Exit For

et les titres des différentes sheets ne sont pas pris en compte, le seul pbl c'est que dans la feuille "master" la premiere ligne devrait contenir les titres du premier onglet copié et elle est vierge.

Quelle modification dois-je apporter au code ?

Merci de votre réponse