Copier-coller des infos d'une feuille vers d'autres feuilles selon un critère

chvalet

XLDnaute Junior
Bonjour

Dans le fichier en PJ
je souhaiterais avoir une macro qui permette de Copier coller des infos de la feuille "base" dans des feuilles des années correspondantes (critère de la colonne 1 "annee")
Ces feuilles "annees" ayant au préalable étaient créées automatiquement

Un forumeur aurait il une solution de macro ?

je vous remercie pour votre aide excelienne .

Chvalet
 

Pièces jointes

  • creer des pages selon critere annee.xlsm
    15.3 KB · Affichages: 46

Staple1600

XLDnaute Barbatruc
Bonjour le fil, le forum

Un peu de recyclage
(issu d'un fil où j'ai récemment répondu)
https://www.excel-downloads.com/thr...uilles-et-onglets-vba.20021981/#post-20163141

J'ai adapté le code à ton fichier exemple
(test OK sur mon PC)
VB:
Sub EclaterClasseurs_BIS()
'archive :JM | 2013
'auteur macro d'origine: JoeMo - avril 2013
Dim lR&, vA As Variant, d As Object, JT As Variant, Wsht As Worksheet
Set Wsht = Sheets("base")
If Wsht.AutoFilterMode Then Wsht.Range("A1").AutoFilter
lR = Wsht.Range("A" & Rows.Count).End(xlUp).Row
vA = Wsht.Range("A2", "P" & lR).Value
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
For i = LBound(vA, 1) To UBound(vA, 1)
    If Not d.exists(vA(i, 1)) Then d.Add vA(i, 1), i
Next i
JT = d.keys
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = LBound(JT) To UBound(JT)
    On Error Resume Next
    Sheets(JT(i)).Delete
    On Error GoTo 0
    With Wsht
        .Range("A1").AutoFilter field:=1, Criteria1:=JT(i)
        .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = JT(i)
        With ActiveSheet.Range("A1")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            Wsht.Select
        End With
    End With
Next i
If Wsht.AutoFilterMode Then Wsht.Range("A1").AutoFilter
Application.DisplayAlerts = True
End Sub
 

Staple1600

XLDnaute Barbatruc
RE

J'ai encore été fouillé dans le grenier de mon PC
Celle-ci fonctionne aussi et est un plus simple à comprendre
VB:
Sub mEclater()
'*archive :JM |=>MX|a-poulsom|101011V38|kw:split/w*
Dim WSt As Worksheet, Plg As Range, c As Range, nFeuilles As New Collection, ws
Application.ScreenUpdating = False
mClean
Set WSt = Worksheets("base") 'adapter avec le nom de la feuille idoine
Set Plg = WSt.Range("A2", WSt.Cells(Rows.Count, 1).End(3))
On Error Resume Next
For Each c In Plg
    nFeuilles.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Plg = WSt.Range("A1:P" & WSt.Cells(Rows.Count, 1).End(3).Row) 'adapter la référence de la plage
For Each ws In nFeuilles
    With Sheets.Add(after:=Worksheets(Worksheets.Count))
    .Name = ws: Plg.AutoFilter 1, ws
    Plg.SpecialCells(12).Copy .Range("A1"): Plg.AutoFilter
    End With
Next ws
WSt.Activate
Application.ScreenUpdating = True
End Sub
Private Sub mClean()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If Not ws.Name Like "base" Then
ws.Delete
End If
Next
End Sub
 

Staple1600

XLDnaute Barbatruc
Re

Oui c'est normal, j'aime pas les infos en général et à la TV en particulier ;)

Il suffit d'adapter cette ligne en conséquence, non ? :rolleyes:
(dans la macro mClean)
If Not ws.Name Like "base" Then

Je te laisse ajouter ce qu'il faut pour que la feuille info ne soit pas supprimer.
 

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 783
Membres
101 817
dernier inscrit
carvajal