Discussion :

[lapagaille]

je suis débutant en macro et je voudrais pouvoir lancer une macro qui permettrait de copier/coller une plage excel dans un nouveau fichier dès lors que jai un changement de valeur dans une colonne cf exemple en pj.

En gros dès lors que la valeur age est différente de la suivante : D8 <> de D9; alors je copie colle toute la plage avec un age égale à 13 dans un nouveau fichier excel; et ainsi de suite pour chaque valeur âge différente (voir ci-dessous nouveau fichier 1, nouveau fichier 2,....)

merci de votre aide

[Daniel.C]

Bonjour,

Essaie ceci; s'il y a quelque chose que tu ne comprends pas, dis-le.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub CreationFichiersAge()
    Dim C As Range     ' pour boucler sur la colonne A
    Dim Ctr As Integer 'Pour le n° de fichier
    Dim DerLigne As Long   'n° de la dernière ligne
    Dim Wbk As Workbook 'variable représentant les classeurs créés
    Dim Sh As Worksheet 'variable représentant la feuille lue
    Dim Ligne As Long 'ligne en écriture
    'Sh est la feuille en lecture
    Set Sh = ThisWorkbook.Sheets(1)
    'détermination de la dernière ligne
    DerLigne = Sh.Cells(Rows.Count, 1).End(xlUp).Row
    'boucle sur les cellules de la colonne A
    For Each C In Range("A2:A" & DerLigne)
        'Création d'un nouveau fichier
        If C.Row = 2 Or C.Offset(0, 3).Value <> C.Offset(-1, 3).Value Then
            'si la ligne > 2 on enregistre et on ferme le fichier
            If C.Row > 2 Then
                Wbk.SaveAs ThisWorkbook.Path & "\" & "Nouveau fichier " & Ctr
                Wbk.Close False
            End If
            Ctr = Ctr + 1
            'création du fichier référencé par la variable Wbk
            Set Wbk = Workbooks.Add
            'recopie des titres
            Ligne = 1
            Wbk.Sheets(1).Cells(Ligne, 1).Resize(1, 4).Value = Sh.Cells(1, 1).Resize(1, 4).Value
        End If
        With Wbk.Sheets(1)
            Ligne = Ligne + 1
            'recopie des 4 cellules
            .Cells(Ligne, 1).Resize(1, 4).Value = Sh.Cells(C.Row, 1).Resize(1, 4).Value
        End With
    Next C
    Wbk.SaveAs ThisWorkbook.Path & "\" & "Nouveau fichier " & Ctr
    Wbk.Close False
End Sub