Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCABonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 20CB546F-D836-44B9-AAF8-02D4CB01755B@microsoft.com...
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCA
Bonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 8AAC8321-81B0-4529-AFBD-4E728621ACA8@microsoft.com...
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCABonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCABonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 20CB546F-D836-44B9-AAF8-02D4CB01755B@microsoft.com...
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCA
Bonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 8AAC8321-81B0-4529-AFBD-4E728621ACA8@microsoft.com...
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCABonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
À) la dernière version que j'ai publiée est plus complète...Elle ne vide pas en autre, la feuille source de ses données.
B) concernant ce message :" Erreur d'exécution '424' : objet requis"
Il est probable qu'il manque un "point" en début d'une ligne" (victime d'une recopie
ou d'une manipulation maladroite d'une ligne de code.
Conséquence, la méthode utilisée sur cette ligne de code n'est pas bien référencée,
car elle n'est pas liée a un objet dans la structure "With .... End With"
À cet égard, la dernière procédure est testée et ne génère pas de message d'erreur
Salutations!
"MCA" a écrit dans le message de news:
Bonjour MichDenis
Merci beaucoup. Finalement, j'ai modifié ton premier script (remplacé la
lettre A par N) et cela fonctionne correctement, selon mon attente. J'ai
toujours le meme message à la fin mais le traitement s'est terminé sans
problème.
Encore merci
--
MCABonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCABonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
À) la dernière version que j'ai publiée est plus complète...Elle ne vide pas en autre, la feuille source de ses données.
B) concernant ce message :" Erreur d'exécution '424' : objet requis"
Il est probable qu'il manque un "point" en début d'une ligne" (victime d'une recopie
ou d'une manipulation maladroite d'une ligne de code.
Conséquence, la méthode utilisée sur cette ligne de code n'est pas bien référencée,
car elle n'est pas liée a un objet dans la structure "With .... End With"
À cet égard, la dernière procédure est testée et ne génère pas de message d'erreur
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 67580EF2-9B20-499A-9CC9-CDBAB3FD21A1@microsoft.com...
Bonjour MichDenis
Merci beaucoup. Finalement, j'ai modifié ton premier script (remplacé la
lettre A par N) et cela fonctionne correctement, selon mon attente. J'ai
toujours le meme message à la fin mais le traitement s'est terminé sans
problème.
Encore merci
--
MCA
Bonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 20CB546F-D836-44B9-AAF8-02D4CB01755B@microsoft.com...
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCA
Bonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news: 8AAC8321-81B0-4529-AFBD-4E728621ACA8@microsoft.com...
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
Bonjour MCA,
À) la dernière version que j'ai publiée est plus complète...Elle ne vide pas en autre, la feuille source de ses données.
B) concernant ce message :" Erreur d'exécution '424' : objet requis"
Il est probable qu'il manque un "point" en début d'une ligne" (victime d'une recopie
ou d'une manipulation maladroite d'une ligne de code.
Conséquence, la méthode utilisée sur cette ligne de code n'est pas bien référencée,
car elle n'est pas liée a un objet dans la structure "With .... End With"
À cet égard, la dernière procédure est testée et ne génère pas de message d'erreur
Salutations!
"MCA" a écrit dans le message de news:
Bonjour MichDenis
Merci beaucoup. Finalement, j'ai modifié ton premier script (remplacé la
lettre A par N) et cela fonctionne correctement, selon mon attente. J'ai
toujours le meme message à la fin mais le traitement s'est terminé sans
problème.
Encore merci
--
MCABonjour MCA,
Voilà la procédure a été modifiée.
'--------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)
Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour michdenis,
Tout d'abord merci de ta réponse. J'ai suivi ton script. Cela fonctionne
mais j'ai un message d'erreur à la fin " Erreur d'exécution '424' : objet
requis ". De plus, il ne me transfère que la 1ère colonne (A). J'aimerais
qu'il me transfère tout le tableau (colonne A à N).
Merci de ton aide
--
MCABonjour MCA,
Essaie ceci :
Fait une sauvegarde de ton classeur.
Celui que tu utiliseras pour le "Découpage" se retrouvera
vide de ses données à la fin de l'opération.
'------------------------------------
Sub Découper()
Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"
'Où sont les données
Set Sh = Worksheets("Feuil1") 'Nom feuille à déterminer
With Sh
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Range("_FilterDataBase") _
.SpecialCells(xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing
End Sub
'-----------------------------------------
Salutations!
"MCA" a écrit dans le message de news:
Bonjour,
Voilà j'ai une feuille de calcul avec beaucoup de lignes. J'ai plusieurs
lignes avec le meme code dans une colonne (A par exemple). J'aimerais
découper cette feuille en plusieurs fichiers à chaque fois que le code change
dans la colonne A.
Est-ce possible ?
Merci de vos réponses.
--
MCA
