copier données tableau dans nouveau classeur en fonction critères

[zbee]

Bonsoir à tous,

Voilà ce que je souhaiterais faire en code VBA

Dans le tableau joint, j'ai fait un tri en fonction du contenu de la colonne D (Service)
Je voudrais pouvoir copier toutes les lignes contenant CC1 et les coller dans un nouveau classeur
et refaire la même manipulation pour toutes les lignes contenant CC2 dans un autre classeur

Une boucle qui ferait quelquechose comme:
Si dans la colonne D je trouve CC1
je copie cette ligne dans un nouveau classeur
je passe à l'autre ligne
Si dans la colonne D je trouve CC2
je copie cette ligne dans un autre nouveau classeur

Quelqu'un a une idée?

 

[flyonets44]

Re : copier données tableau dans nouveau classeur en fonction critères

Bonjour
Voici une solution en retour
pour lancer les macros : alt+F8 proctstandard
Cordialement
Flyonets

 

[job75]

Re : copier données tableau dans nouveau classeur en fonction critères

Bonjour zbee, flyonets44,

Voici une autre solution qui utilise aussi le Filtre automatique.

Il n'est pas nécessaire que la colonne D soit triée :

Sub CréationFichiers()
Dim derlig&, d As Object, cel As Range, a, plage As Range
derlig = [D65536].End(xlUp).Row
If derlig = 1 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
'---liste des Services sans doublon---
Set d = CreateObject("Scripting.Dictionary")
For Each cel In [D2].Resize(derlig - 1)
  If cel <> "" Then d(cel.Value) = cel.Value
Next
'---création des fichiers---
For Each a In d.keys
  ActiveSheet.Copy
  ActiveSheet.Name = a
  Set plage = ActiveSheet.[D1].Resize(derlig)
  plage.AutoFilter 1, "<>" & a
  Set plage = plage.Offset(1).SpecialCells(xlCellTypeVisible)
  ActiveSheet.AutoFilterMode = False
  plage.EntireRow.Delete
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a
  ActiveWorkbook.Close
Next
End Sub

Fichier joint.

A+

 

[job75]

Re : copier données tableau dans nouveau classeur en fonction critères

Re,

Evidemment si l'on ne veut créer les fichiers que pour certains services c'est plus simple.

Il suffit de les lister dans le tableau tablo :

Sub CréationFichiers()
Dim derlig&, tablo, a, plage As Range
derlig = [D65536].End(xlUp).Row
If derlig = 1 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
'---liste des Services ---
tablo = Array("CC1", "CC2")
'---création des fichiers---
For Each a In tablo
  ActiveSheet.Copy
  ActiveSheet.Name = a
  Set plage = ActiveSheet.[D1].Resize(derlig)
  plage.AutoFilter 1, "<>" & a
  Set plage = plage.Offset(1).SpecialCells(xlCellTypeVisible)
  ActiveSheet.AutoFilterMode = False
  plage.EntireRow.Delete
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a
  ActiveWorkbook.Close
Next
End Sub

Fichier (2).

A+

 

[job75]

Re : copier données tableau dans nouveau classeur en fonction critères

Re,

Juste un détail évident.

Les noms des Services ne doivent pas contenir de caractères interdits pour les noms de fichiers ou les noms de feuilles...

Edit : catactères interdits :

- nom de fichier / \ : * ? " < > |

- nom de feuille / \ : * ? [ ] ' plus de 31 caractères

A+

 

[job75]

Re : copier données tableau dans nouveau classeur en fonction critères

Re, pour terminer,

On aura remarqué que la macro supprime une ligne vide, avant le texte Touches Ctrl+A...

Si cela est gênant, utiliser les macros des fichiers bis joints, où l'on notera :

Set plage = plage.Offset(1).Resize(derlig - 1).SpecialCells(xlCellTypeVisible)

Edit : j'ai simplifié la macro du fichier (1bis) par rapport au (2bis) au niveau du filtrage

A+

 

[zbee]

Re : copier données tableau dans nouveau classeur en fonction critères

Merci beaucoup Job75,

comme je débute en VBA,
j'ai peu de mal à décripter toutes les instructions
peux-tu me traduire en français les différentes instructions
histoire que je sois autonome la prochaine fois et surtout que je puisse adapter le code dans d'autres situations

Et aussi les 2 fichiers créés ne restent pas afficher
comment faire pour qu'ils restent affichés?
merci

Sub CréationFichiers()
Dim derlig&, d As Object, cel As Range, a, plage As Range
derlig = [D65536].End(xlUp).Row
If derlig = 1 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
'---liste des Services sans doublon---
Set d = CreateObject("Scripting.Dictionary")
For Each cel In [D2].Resize(derlig - 1)
If cel <> "" Then d(cel.Value) = cel.Value
Next
'---création des fichiers---
For Each a In d.keys
ActiveSheet.Copy
ActiveSheet.Name = a
If d.Count > 1 Then
Set plage = ActiveSheet.[D1].Resize(derlig)
plage.AutoFilter 1, "<>" & a
Set plage = plage.Offset(1).Resize(derlig - 1).SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
plage.EntireRow.Delete
End If
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a
ActiveWorkbook.Close
Next
End Sub

 

[job75]

Re : copier données tableau dans nouveau classeur en fonction critères

Bonjour zbee, le forum,

En général il est préférable de fermer les fichiers créés mais enfin...

Voir le fichier joint avec plein de commentaires explicatifs.

J'ai mis un contrôle d'erreur On Error Resume Next pour le cas où l'on lance la macro avec les fichiers CC1 et/ou CC2 ouverts.

A+

 

[zbee]

Re : copier données tableau dans nouveau classeur en fonction critères

Merci pour tout Job75
c'est + clair
bonne soirée