Générer plusieurs fichiers à partir d'un seul Pack office 2003

Le
kristofb
Bonjour à tous,
Merci à ceux qui vont se pencher sans tomber sur mon cas.

J'ai un fichier avec des data par agences, le code de l'agence est en
colonne A, le libellé en B
les données vont de E à P. Le nombre de lignes par agence est variable
et je ne connais pas à l'avance le nombre d'agences.

L'objectif est de générer un fichier par agence pour le rendre
disponible sur un serveur pour chaque agence \serveurcheminsurserveur
XX où XX est le code de l'agence.

Le nombre des agences fluctu au cours des mois et je voudrais
automatiser celà.
Cerise sur le gateau, je souhaiterai avoir dans l'entête de l'édition
le code et le libellé de l'agence.

Aujourd'hui dans une macro je met un code agence dans une zone et je
lance une autre macro
qui filtre sur ce code, qui copie les données dans un autre fichier et
enregistre sur le serveur dans le bon répertoire.
Et l'opération se répète autant de fois que je connais les agences. A
chaque création je vais modifier ma macro au secours.

De plus je conserve ma colonne A et B puisque je ne sais pas comment
ajouter le code et le libellé de l'agence dans l'entête du tableau
généré, ce qui me fait perdre une quarantaine de caractères dans la
largeur de l'état.

Si l'un des Dieux de ce forum (les informaticiens étaient considérés
comme tels il y a une vingtaine d'années) peut me guider vers une
solution pratique je l'en remercie par avance.

L'urgent est fait, l'impossible est en cours, pour les mirables
prévoir un délais.
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichD
Le #23877991
Bonjour,

A )
Tu dis avoir développé une macro...jusqu'ici, tu sembles la garder pour toi !

B ) À chaque fois que tu fais rouler la macro, que doit-il se passer pour les fichiers qui ont déjà été créés ?
1. On recrée tous les fichiers sans exception avec les nouvelles données et on écrase les fichiers déjà existants ?
2. Tu veux seulement créer les fichiers inexistants sans toucher au fichier déjà créé ?
3. Autre à définir...

C ) Lors de la création des fichiers, tu veux y copier quoi ? Les colonnes A, B, et les données des colonnes E à P SEULEMENT
?
Quelle disposition doivent avoir ces données dans le nouveau fichier? De A1 à Mx sans colonne vide ?

D ) C'est quoi pour toi : "l'entête de l'édition" ? La barre de titre de l'application lorsque le fichier est ouvert ? Autre
chose ?

E ) Quel nom doit avoir la feuille dans chacun des fichiers créés ?


MichD
------------------------------------------
"kristofb" a écrit dans le message de groupe de discussion :


Bonjour à tous,
Merci à ceux qui vont se pencher ... sans tomber sur mon cas.

J'ai un fichier avec des data par agences, le code de l'agence est en
colonne A, le libellé en B
les données vont de E à P. Le nombre de lignes par agence est variable
et je ne connais pas à l'avance le nombre d'agences.

L'objectif est de générer un fichier par agence pour le rendre
disponible sur un serveur pour chaque agence \serveurcheminsurserveur
XX où XX est le code de l'agence.

Le nombre des agences fluctu au cours des mois et je voudrais
automatiser celà.
Cerise sur le gateau, je souhaiterai avoir dans l'entête de l'édition
le code et le libellé de l'agence.

Aujourd'hui dans une macro je met un code agence dans une zone et je
lance une autre macro
qui filtre sur ce code, qui copie les données dans un autre fichier et
enregistre sur le serveur dans le bon répertoire.
Et l'opération se répète autant de fois que je connais les agences. A
chaque création je vais modifier ma macro... au secours.

De plus je conserve ma colonne A et B puisque je ne sais pas comment
ajouter le code et le libellé de l'agence dans l'entête du tableau
généré, ce qui me fait perdre une quarantaine de caractères dans la
largeur de l'état.

Si l'un des Dieux de ce forum (les informaticiens étaient considérés
comme tels il y a une vingtaine d'années) peut me guider vers une
solution pratique je l'en remercie par avance.

L'urgent est fait, l'impossible est en cours, pour les mirables ...
prévoir un délais.
kristofb
Le #23882161
MichD,
Tout d'abord merci et je te prie de bien vouloir excuser mon manque de
précisions.

A) Tu trouveras la macro Macro en fin de message. (il sagit plus d'un
enregistrement de macro qu'un développement)
B) Les fichiers écraseront les fichiers déjà existant et ils seront
créés si inexistant
C) Les colonnes A et B ne me serviront que pour le titre de l'état et
la rupture par agence, elle deviennent ensuite inutile.
D) l'Entête d'édition correspond pour moi à ce que l'on trouve dans
mise en page Entête/pied de page//Entête personalisée//Partie central e
E) peut importe le nom de la feuille, elle pourrait par exemple avoir
le code de l'agence.(pour le moment j'ai laissé feuill1).

Le projet aévolué mais, mon problème reste l'automatisation de la
division du fichier en fonction des codes agences présent dans le
fichiers. Le fichier d'origine contient les données de toutes les
agences, l'objectif est de faire un fichier par agence sans avoir à
alimenter "manuellement" les codes agences dans la macro.

Je pensais avoir posté ma réponse hier mais j'ai du me planter elle
n'est pas affichée aujourdhui.
Encore Merci à toi et à ceux qui me dirigeront vers une solution.

voici le source :
'Déclaration variable zagence pour utilisation inter macro
Public zagence As String
Sub ipmmat()
' chargement des datas récupérées par ftp
Workbooks.OpenText Filename:="C:FICHIERSfipmmat.txt", Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited,
TextQualifier:=xlNone, _
ConsecutiveDelimiter:úlse, Tab:úlse, Semicolon:=True,
Comma:úlse _
, Space:úlse, Other:úlse, FieldInfo:=Array(Array(1, 2),
Array(2, 2), _
Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 1), Array(7,
2), Array(8, 2), Array(9, 2), _
Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2),
Array(14, 2), Array(15, 2), Array( _
16, 2), Array(17, 1), Array(18, 1), Array(19, 1), Array(20,
2), Array(21, 2), Array(22, 1)) _
, TrailingMinusNumbers:=True
Selection.CurrentRegion.Select
Selection.Copy
' ouverture fichier entete
Workbooks.Open Filename:="C:Tableaux RS6000fipmmat-vide.xls", _
Origin:=xlWindows
' copie data dans fichier d'entete
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse
Application.CutCopyMode = False
' mise en forme période achat mm-ssaa
Columns("V:V").Select
Selection.NumberFormat = "00-0000"
Range("A1").Select
' enregistrement fichier complet avec désactivation puis
réactivation msgbox
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:FICHIERSfipmmat-toutes-
ag.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:úlse, CreateBackup:úlse
Application.DisplayAlerts = True
' mise en place filtre
Range("A1").Select
Selection.AutoFilter
' mise en place agence et lancement macro agence
' Dim zagence As String
zagence = "01"
macro_agence
zagence = "02"
macro_agence
' Fermeture fichiers ouverts et sortie de l'application
Application.DisplayAlerts = False
ActiveWindow.Close
ActiveWindow.Close
Application.Quit
End Sub
' macro speciale agence
Sub macro_agence()
Selection.AutoFilter Field:=3, Criteria1:="=" & zagence
Selection.CurrentRegion.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("L:Q").Select
Selection.Delete Shift:=xlToLeft
Range("L1").Formula = "pos"
Range("M1").Formula =
"Commentaires "
Cells.Select
Range("A1").Activate
Cells.EntireColumn.AutoFit
Columns("A:B").Select
Selection.ColumnWidth = 0
Range("A1").Select
' mise en forme Edition
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Gras""&16INVENTAIRE PARC MATERIEL "
_
& Worksheets("Feuil1").Range("A2") & " " &
Worksheets("Feuil1").Range("B2")
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
Application.DisplayAlerts = False
chemin = "C:FICHIERS"
nom_du_fichier = "ipmmat-" & zagence
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=chemin & nom_du_fichier & ".xls",
_
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:úlse, CreateBackup:úlse
Application.DisplayAlerts = True
ActiveWindow.Close
End Sub
MichD
Le #23882331
Voici un fichier qui crée des fichiers sur le serveur à partir des données dans la colonne A
du fichier dans lequel sera copiée la macro dans un module standard. La ligne 1 est réputée
servir d'étiquette de colonne.


À copier dans un module standard et ne pas oublier de définir les 2 variables
dans la procédure.
'--------------------------------------------
Sub Création_Fichier_Sur_Serveur()

Dim C As New Collection, A As Integer
Dim Sh As Worksheet, Nb As Long
Dim Feuille As String, Serveur_Chemin As String

'********Variables à définir**********

Feuille = "Feuil1" 'nom de l'onglet de la feuille
Serveur_Chemin = "\serveurcheminsurserveur" 'à définir

'***************************************************

On Error Resume Next
'Empêche le rafraîchissement de l'écran durant
'le temps que dure la macro.
Application.ScreenUpdating = False
With Worksheets(Feuille)
'Extrait le numéro dernière ligne colonne A
Nb = .Range("A65356").End(xlUp).Row
'Une boucle sur toutes les données de la colonne A
'Débutant en ligne 2, ligne 1 réservée pour les étiquettes
For A = 2 To Nb
'C est un objet collection qui permet d'ajouter seulement
'des éléments différents, donc pas de doublons. Chaque
'élément va servir à extraire des données dans un filtre
'automatique pour chaque No de police.
If .Range("A" & A).Value <> "" Then
C.Add .Range("A" & A).Text, .Range("A" & A).Value
End If
Next
End With

'Maintenant pour chaque élément de la collection de valeur unique
'de la colonne A
For A = 1 To C.Count
'Si le fichier n'existe pas sur le serveur
If Dir(Serveur_Chemin & C(A) & ".xls") = "" Then
'Création de celui-ci
'Ajoute un classeur ayant seulement une feuille
Workbooks.Add -4167
Set Sh = ActiveWorkbook.Worksheets(1)
'Le nom de cette feuille
Sh.Name = C(A)
With Sh
.Range("A1") = "Code de l'agence"
.Range("B1") = "Libellé de l'agence"
.Range("C1") = "Famille matériel"
.Range("D1") = "Sous-famille"
.Range("E1") = "Code du matériel"
.Range("F1") = "Désignation 1"
.Range("G1") = "Désignation 2"
.Range("H1") = "Marque"
.Range("i1") = "Type"
.Range("J1") = "N° Série"
.Range("K1") = "Immatriculation"
.Range("L1") = "Commentaires"
.Range("M1") = "Commentaires"
With .Range("A1:M1")
.Font.Size = 14
.Font.Bold = True
.EntireColumn.AutoFit
End With
End With
'Sauvegarde du fichier nouveau vers le serveur et le
'chemin du serveur en utilisant le code de l'agence
Sh.Parent.SaveAs Serveur_Chemin & C(A) & ".xls"
'Fermeture du nouveau fichier
Sh.Parent.Close False
End If
Next
Set Sh = Nothing: Set C = Nothing
End Sub
'--------------------------------------------



MichD
------------------------------------------
"MichD" a écrit dans le message de groupe de discussion : j7jg0c$g74$

Bonjour,

A )
Tu dis avoir développé une macro...jusqu'ici, tu sembles la garder pour toi !

B ) À chaque fois que tu fais rouler la macro, que doit-il se passer pour les fichiers qui ont déjà été créés ?
1. On recrée tous les fichiers sans exception avec les nouvelles données et on écrase les fichiers déjà existants ?
2. Tu veux seulement créer les fichiers inexistants sans toucher au fichier déjà créé ?
3. Autre à définir...

C ) Lors de la création des fichiers, tu veux y copier quoi ? Les colonnes A, B, et les données des colonnes E à P SEULEMENT
?
Quelle disposition doivent avoir ces données dans le nouveau fichier? De A1 à Mx sans colonne vide ?

D ) C'est quoi pour toi : "l'entête de l'édition" ? La barre de titre de l'application lorsque le fichier est ouvert ? Autre
chose ?

E ) Quel nom doit avoir la feuille dans chacun des fichiers créés ?


MichD
------------------------------------------
"kristofb" a écrit dans le message de groupe de discussion :


Bonjour à tous,
Merci à ceux qui vont se pencher ... sans tomber sur mon cas.

J'ai un fichier avec des data par agences, le code de l'agence est en
colonne A, le libellé en B
les données vont de E à P. Le nombre de lignes par agence est variable
et je ne connais pas à l'avance le nombre d'agences.

L'objectif est de générer un fichier par agence pour le rendre
disponible sur un serveur pour chaque agence \serveurcheminsurserveur
XX où XX est le code de l'agence.

Le nombre des agences fluctu au cours des mois et je voudrais
automatiser celà.
Cerise sur le gateau, je souhaiterai avoir dans l'entête de l'édition
le code et le libellé de l'agence.

Aujourd'hui dans une macro je met un code agence dans une zone et je
lance une autre macro
qui filtre sur ce code, qui copie les données dans un autre fichier et
enregistre sur le serveur dans le bon répertoire.
Et l'opération se répète autant de fois que je connais les agences. A
chaque création je vais modifier ma macro... au secours.

De plus je conserve ma colonne A et B puisque je ne sais pas comment
ajouter le code et le libellé de l'agence dans l'entête du tableau
généré, ce qui me fait perdre une quarantaine de caractères dans la
largeur de l'état.

Si l'un des Dieux de ce forum (les informaticiens étaient considérés
comme tels il y a une vingtaine d'années) peut me guider vers une
solution pratique je l'en remercie par avance.

L'urgent est fait, l'impossible est en cours, pour les mirables ...
prévoir un délais.
MichD
Le #23882311
Réponse à ton autre message.



MichD
------------------------------------------
Maude Este
Le #23884491
"kristofb" a écrit
J'ai un fichier avec des data par agences, le code de l'agence est en
colonne A, le libellé en B
les données vont de E à P. Le nombre de lignes par agence est variable
et je ne connais pas à l'avance le nombre d'agences.

L'objectif est de générer un fichier par agence pour le rendre
disponible sur un serveur pour chaque agence \serveurcheminsurserveur
XX où XX est le code de l'agence.

Le nombre des agences fluctu au cours des mois et je voudrais
automatiser celà.

;o)))
http://chandoo.org/wp/2011/10/19/split-excel-file-into-many/
kristofb
Le #23889131
Bonjour à tous et merci à MichD et Maude.
Les restrictions d'accès internet font que je ne peux travailler sur
le lien de Maude,
je regarderai celà ce WE de chez moi.

Concernant la solution de MichD,
J'ai bien la création d'autant de fichier que nécessaire là où je
souhaite les avoir, sous le bon nom,
les feuilles sont bien nommées avec le code agence mais j'ai un soucis
avec la récupération des datas.

Je ne maitrise pas suffisemment VBA mais je suppose que le problème
est lié à mes codes agences qui peuvent être Alphanumérique 01 J0 T 1
par exemple. Qu'en pensez vous ?

2) Workbooks.Add celà me parle mais pas -4167 pouvez-vous
m'expliquer ?

Le source modifié
'Déclaration variables
Public zagence As String
Dim C As New Collection, A As Integer
Dim Sh As Worksheet, Nb As Long
Dim Feuille As String, Serveur_chemin As String
Sub ipmmat()
'Empêche le rafraîchissement de l'écran durant
'le temps que dure la macro.
Application.ScreenUpdating = False
' chargement des datas récupérées par ftp
Workbooks.OpenText Filename:="C:FICHIERSfipmmat.txt", Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited,
TextQualifier:=xlNone, _
ConsecutiveDelimiter:úlse, Tab:úlse, Semicolon:=True,
Comma:úlse _
, Space:úlse, Other:úlse, FieldInfo:=Array(Array(1, 2),
Array(2, 2), _
Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 1), Array(7,
2), Array(8, 2), Array(9, 2), _
Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2),
Array(14, 2), Array(15, 2), Array( _
16, 2), Array(17, 1), Array(18, 1), Array(19, 1), Array(20,
2), Array(21, 2), Array(22, 1)) _
, TrailingMinusNumbers:=True
Selection.CurrentRegion.Select
Selection.Copy
' ouverture fichier entete
Workbooks.Open Filename:="C:Tableaux RS6000fipmmat-vide.xls", _
Origin:=xlWindows
' copie data dans fichier d'entete
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse
Application.CutCopyMode = False
' mise en forme période achat mm-ssaa
Columns("V:V").Select
Selection.NumberFormat = "00-0000"
' tri des données sur code agence
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortTextAsNumbers
Range("A1").Select
' enregistrement fichier complet avec désactivation puis
réactivation msgbox
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:FICHIERSfipmmat-toutes-
ag.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:úlse, CreateBackup:úlse
Application.DisplayAlerts = True
' Suppression colonne Type de parc et région
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
' mise en place filtre
Range("A1").Select
Selection.AutoFilter
' La colonne A contient désormais les codes agences
Feuille = "Feuil1"
Serveur_chemin = "C:FICHIERSInventaire-Parc-Ag-"
On Error Resume Next
With Worksheets(Feuille)
'Extrait le numéro dernière ligne colonne A
Nb = .Range("A65356").End(xlUp).Row
'Une boucle sur toutes les données de la colonne A Débutant en
ligne 2
For A = 2 To Nb
'C est un objet collection qui permet d'ajouter seulement
'des éléments différents, donc pas de doublons. Chaque
'élément va servir à extraire des données dans un filtre
'automatique pour chaque No de police.
If .Range("A" & A).Value <> "" Then
C.Add .Range("A" & A).Text, .Range("A" & A).Value
End If
Next
End With
'Maintenant pour chaque élément de la collection de valeur unique
'de la colonne A
For A = 1 To C.Count
' Copie des données
Selection.AutoFilter Field:=1, Criteria1:="=" & A
Selection.CurrentRegion.Select
Selection.Copy
'Si le fichier n'existe pas sur le serveur
If Dir(Serveur_chemin & C(A) & ".xls") = "" Then
'Création de celui-ci
'Ajoute un classeur ayant seulement une feuille
Workbooks.Add -4167
Set Sh = ActiveWorkbook.Worksheets(1)
'Le nom de cette feuille
Sh.Name = C(A)
ActiveSheet.Paste
With Sh
.Range("A1") = "Code de l'agence"
.Range("B1") = "Libellé de l'agence"
.Range("C1") = "Famille matériel"
.Range("D1") = "Sous-famille"
.Range("E1") = "Code du matériel"
.Range("F1") = "Désignation 1"
.Range("G1") = "Désignation 2"
.Range("H1") = "Marque"
.Range("i1") = "Type"
.Range("J1") = "N° Série"
.Range("K1") = "Immatriculation"
.Range("L1") = "Commentaires"
.Range("M1") = "Commentaires"
With .Range("A1:M1")
.Font.Size = 14
.Font.Bold = True
.EntireColumn.AutoFit
End With
End With
'Sauvegarde du fichier nouveau vers le serveur et le
'chemin du serveur en utilisant le code de l'agence
Sh.Parent.SaveAs Serveur_chemin & C(A) & ".xls"
'Fermeture du nouveau fichier
Sh.Parent.Close False
End If
Next
Set Sh = Nothing: Set C = Nothing
Application.DisplayAlerts = False
ActiveWindow.Close
ActiveWindow.Close
Application.Quit
End Sub
kristofb
Le #23889201
Re bonjour,

J'ai compris mon erreur sur le filtre ... j'ai mis
Selection.AutoFilter Field:=1, Criteria1:="=" & A
au lieu de
Selection.AutoFilter Field:=1, Criteria1:="=" & C(A)

Merci de votre aide.
MichD
Le #23890001
| 2) Workbooks.Add celà me parle mais pas -4167 pouvez-vous

Si tu places le curseur sur ADD à la ligne Workbooks.ADD et tu appelles l'aide VBA par F1

C'est ce que tu vas trouver :
================================================================== Workbooks.Add, méthode
Cette méthode crée un nouveau classeur, qui devient le classeur actif.
Syntaxe

expression.Add(Template) <<<<==================
expression Variable qui représente un objet Workbooks.

Paramètres

Nom Obligatoire/Facultatif Type de données Description
Template Facultatif Variante Détermine la façon dont le nouveau classeur est créé. Si cet argument est une chaîne spécifiant
le nom d'un fichier Microsoft Excel existant, le nouveau classeur est créé d'après le modèle de ce fichier. Si cet argument
est une constante, le nouveau classeur contient une seule feuille du type spécifié. Il peut s'agir d'une des constantes
XlWBATemplate suivantes : xlWBATChart, xlWBATExcel4IntlMacroSheet, xlWBATExcel4MacroSheet ou xlWBATWorksheet. Si cet argument
est omis, Microsoft Excel crée un nouveau classeur avec un certain nombre de feuilles vierges (ce nombre est défini par la
propriété SheetsInNewWorkbook).
==================================================================
Dans une macro, le "TEMPLATE" (TYPE DE CLASSEUR) à créer on peut le définir comme ceci :
'-----------------------------
Sub test()
Dim X As XlWBATemplate
X = xlWBATWorksheet
'X = -4167 'C'est la valeur numérique de la constante. C'est plus court à écrire ! ;-))
Workbooks.Add X

OU directement comme ceci :
Workbooks.Add xlWBATWorksheet

Si on n'utilise pas de TEMPLATE, on aura un classeur avec le nombre
de feuille défini par défaut des les options d'Excel.
Workbooks.Add

End Sub
'-----------------------------

Si dans la feuille, il y a des données à extraire, il aurait fallu utiliser ce type de macro :

'-----------------------------------------------
Sub Filtre()

Dim C As New Collection, A As Integer
Dim Sh As Worksheet, Nb As Long
Dim Feuille As String, Serveur_Chemin As String

'********Variables à définir**********
Feuille = "Feuil1" 'nom de l'onglet de la feuille
Serveur_Chemin = "\serveurcheminsurserveur"

'***************************************************

On Error Resume Next
'Empêche le rafraîchissement de l'écran durant
'le temps que dure la macro.
Application.ScreenUpdating = False
With Worksheets("Feuil1")
'Extrait le numéro dernière ligne colonne A
Nb = .Range("A65356").End(xlUp).Row
'Une boucle sur toutes les données de la colonne A
'Débutant en ligne 2, ligne 1 réservée pour les étiquettes
For A = 2 To Nb
'C est un objet collection qui permet d'ajouter seulement
'des éléments différents, donc pas de doublons. Chaque
'élément va servir à extraire des données dans un filtre
'automatique pour chaque No de police.
If .Range("A" & A).Value <> "" Then
C.Add .Range("A" & A).Text, .Range("A" & A).Value
End If
Next
End With
Application.ScreenUpdating = False
'Maintenant pour chaque élément de la collection de valeur unique
'de la colonne A
For A = 1 To C.Count
With Sheets("Feuil1").Range("A1:P" & Nb)
.AutoFilter Field:=1, Criteria1:=C(A)
End With
'Ajoute un classeur ayant seulement une feuille
Workbooks.Add -4167
Set Sh = ActiveWorkbook.Worksheets(1)
'Le nom de cette feuille
Sh.Name = C(A)
'Copie de la plage filtrée vers la nouvelle feuille
'dans le nouveau classeur
Worksheets(Feuille).Range("_FilterDataBase"). _
SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
'Suppression des colonnes C et D de la nouvelle feuille
'qui ne contient pas de données ou ces données ne sont
'pas pertinentes
Sh.Range("C:D").EntireColumn.Delete
Sh.Range("L1:M1") = "Commentaire"
Sh.Range("A1:M1").Font.Size = 14
Sh.Range("A1:M1").Font.Bold = True
Sh.Range("A1:M1").EntireColumn.AutoFit


'Sauvegarde du fichier nouveau vers le serveur et le
'chemin du serveur en utilisant le code de l'agence
Sh.Parent.SaveAs Serveur_Chemin & C(A) & ".xls"
'Fermeture du nouveau fichier
Sh.Parent.Close False
Next
'Enlever le filtre sur la feuille à la fin
Sheets(Feuille).Range("A1").AutoFilter
Application.ScreenUpdating = true
Set Sh = Nothing: Set C = Nothing

End Sub
'-----------------------------------------------





MichD
------------------------------------------
"kristofb" a écrit dans le message de groupe de discussion :


Bonjour à tous et merci à MichD et Maude.
Les restrictions d'accès internet font que je ne peux travailler sur
le lien de Maude,
je regarderai celà ce WE de chez moi.

Concernant la solution de MichD,
J'ai bien la création d'autant de fichier que nécessaire là où je
souhaite les avoir, sous le bon nom,
les feuilles sont bien nommées avec le code agence mais j'ai un soucis
avec la récupération des datas.

Je ne maitrise pas suffisemment VBA mais je suppose que le problème
est lié à mes codes agences qui peuvent être Alphanumérique 01 J0 T1
par exemple. Qu'en pensez vous ?

2) Workbooks.Add celà me parle mais pas -4167 pouvez-vous
m'expliquer ?

Le source modifié
'Déclaration variables
Public zagence As String
Dim C As New Collection, A As Integer
Dim Sh As Worksheet, Nb As Long
Dim Feuille As String, Serveur_chemin As String
Sub ipmmat()
'Empêche le rafraîchissement de l'écran durant
'le temps que dure la macro.
Application.ScreenUpdating = False
' chargement des datas récupérées par ftp
Workbooks.OpenText Filename:="C:FICHIERSfipmmat.txt", Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited,
TextQualifier:=xlNone, _
ConsecutiveDelimiter:úlse, Tab:úlse, Semicolon:=True,
Comma:úlse _
, Space:úlse, Other:úlse, FieldInfo:=Array(Array(1, 2),
Array(2, 2), _
Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 1), Array(7,
2), Array(8, 2), Array(9, 2), _
Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2),
Array(14, 2), Array(15, 2), Array( _
16, 2), Array(17, 1), Array(18, 1), Array(19, 1), Array(20,
2), Array(21, 2), Array(22, 1)) _
, TrailingMinusNumbers:=True
Selection.CurrentRegion.Select
Selection.Copy
' ouverture fichier entete
Workbooks.Open Filename:="C:Tableaux RS6000fipmmat-vide.xls", _
Origin:=xlWindows
' copie data dans fichier d'entete
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse
Application.CutCopyMode = False
' mise en forme période achat mm-ssaa
Columns("V:V").Select
Selection.NumberFormat = "00-0000"
' tri des données sur code agence
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortTextAsNumbers
Range("A1").Select
' enregistrement fichier complet avec désactivation puis
réactivation msgbox
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:FICHIERSfipmmat-toutes-
ag.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:úlse, CreateBackup:úlse
Application.DisplayAlerts = True
' Suppression colonne Type de parc et région
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
' mise en place filtre
Range("A1").Select
Selection.AutoFilter
' La colonne A contient désormais les codes agences
Feuille = "Feuil1"
Serveur_chemin = "C:FICHIERSInventaire-Parc-Ag-"
On Error Resume Next
With Worksheets(Feuille)
'Extrait le numéro dernière ligne colonne A
Nb = .Range("A65356").End(xlUp).Row
'Une boucle sur toutes les données de la colonne A Débutant en
ligne 2
For A = 2 To Nb
'C est un objet collection qui permet d'ajouter seulement
'des éléments différents, donc pas de doublons. Chaque
'élément va servir à extraire des données dans un filtre
'automatique pour chaque No de police.
If .Range("A" & A).Value <> "" Then
C.Add .Range("A" & A).Text, .Range("A" & A).Value
End If
Next
End With
'Maintenant pour chaque élément de la collection de valeur unique
'de la colonne A
For A = 1 To C.Count
' Copie des données
Selection.AutoFilter Field:=1, Criteria1:="=" & A
Selection.CurrentRegion.Select
Selection.Copy
'Si le fichier n'existe pas sur le serveur
If Dir(Serveur_chemin & C(A) & ".xls") = "" Then
'Création de celui-ci
'Ajoute un classeur ayant seulement une feuille
Workbooks.Add -4167
Set Sh = ActiveWorkbook.Worksheets(1)
'Le nom de cette feuille
Sh.Name = C(A)
ActiveSheet.Paste
With Sh
.Range("A1") = "Code de l'agence"
.Range("B1") = "Libellé de l'agence"
.Range("C1") = "Famille matériel"
.Range("D1") = "Sous-famille"
.Range("E1") = "Code du matériel"
.Range("F1") = "Désignation 1"
.Range("G1") = "Désignation 2"
.Range("H1") = "Marque"
.Range("i1") = "Type"
.Range("J1") = "N° Série"
.Range("K1") = "Immatriculation"
.Range("L1") = "Commentaires"
.Range("M1") = "Commentaires"
With .Range("A1:M1")
.Font.Size = 14
.Font.Bold = True
.EntireColumn.AutoFit
End With
End With
'Sauvegarde du fichier nouveau vers le serveur et le
'chemin du serveur en utilisant le code de l'agence
Sh.Parent.SaveAs Serveur_chemin & C(A) & ".xls"
'Fermeture du nouveau fichier
Sh.Parent.Close False
End If
Next
Set Sh = Nothing: Set C = Nothing
Application.DisplayAlerts = False
ActiveWindow.Close
ActiveWindow.Close
Application.Quit
End Sub
Publicité
Poster une réponse
Anonyme