XL 2016 copier et garder la largeur des col

[linebich]

Bonsoir forum ,
je reviens vers vous pour m'aider à ajouter une petite correction a ce code qui a pour objectif de découper une base selon les pays , en fichier excel le code fonctionne mais la largeur des colonnes du résultat ne s'adapte pas au contenu , ou au moins garde la même largeur de la base global j’espère avoir bien expliquer le problème
merci pour tout retour de vos parts
Option Explicit

Sub decouper_dans_fichier()
Dim plage As Range, t, collPays As New Collection, i&, wbk As Workbook, P, fichier

Application.ScreenUpdating = False 'on fige l'écran
With Sheets("Fichier Import")
If .FilterMode Then .ShowAllData 'si filtre alors on affiche tout
Set plage = .Range("a1").CurrentRegion 'plage est la plage des données source
plage.Sort key1:=.Cells(1, "D"), order1:=xlAscending, Header:=xlYes 'Tri de la plage selon le pays
t = plage.Columns(4) 'transfert dans le tableau t de la colonne des entité de la plage
On Error Resume Next ' si erreur (pays déjà dans la collection collPays), on continue
For i = 2 To UBound(t) 'boucle sur tous les pays de la plage (tableau t)
collPays.Add Item:=t(i, 1), Key:=t(i, 1) 'on ajoute le pays dans la collection collPays
Next i
Application.DisplayAlerts = False 'on se dispense des messages d'alerte
Set wbk = Workbooks.Add 'on ajoute un nouveau classeur
For i = wbk.Sheets.Count To 2 Step -1: Sheets(i).Delete: Next 'on ne garde que la feuille 1
For Each P In collPays 'pour chaque pays p de la collection collPays
'on construit le nom du fichier correspondant au xlsx de l'entité
'puis on détruit le fichier sur le disque
fichier = ThisWorkbook.Path: If Right(fichier, 1) <> "\" Then fichier = fichier & "\"

fichier = fichier & P: Kill fichier
plage.AutoFilter Field:=4, Criteria1:=P 'on filtre la plage sur le pays p
wbk.Sheets(1).Cells.Clear 'on efface la feuille 1 du nouveau classeur
'on copie la plage filtrée dans le nouveau classeur
plage.SpecialCells(xlCellTypeVisible).Copy wbk.Sheets(1).Range("a1")

'on sauvegarde le nouveau classeur sous format
wbk.SaveAs Filename:=fichier, CreateBackup:=False
wbk.Sheets(1).Columns("A:O").AutoFit
Next P
wbk.Close savechanges:=False 'on ferme le nouveau classeur
.ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[Staple1600]

Bonsoir le fil,

linebich
Utilises les balises BBCODE pour formater le code VBA
Ton message sera plus agréable à lire

Sub decouper_dans_fichier()
Dim plage As Range, t, collPays As New Collection, i&, wbk As Workbook, P, fichier

Application.ScreenUpdating = False 'on fige l'écran
With Sheets("Fichier Import")
If .FilterMode Then .ShowAllData 'si filtre alors on affiche tout
Set plage = .Range("a1").CurrentRegion 'plage est la plage des données source
plage.Sort key1:=.Cells(1, "D"), order1:=xlAscending, Header:=xlYes 'Tri de la plage selon le pays
t = plage.Columns(4) 'transfert dans le tableau t de la colonne des entité de la plage
On Error Resume Next ' si erreur (pays déjà dans la collection collPays), on continue
For i = 2 To UBound(t) 'boucle sur tous les pays de la plage (tableau t)
collPays.Add Item:=t(i, 1), Key:=t(i, 1) 'on ajoute le pays dans la collection collPays
Next i
Application.DisplayAlerts = False 'on se dispense des messages d'alerte
Set wbk = Workbooks.Add 'on ajoute un nouveau classeur
For i = wbk.Sheets.Count To 2 Step -1: Sheets(i).Delete: Next 'on ne garde que la feuille 1
For Each P In collPays 'pour chaque pays p de la collection collPays
'on construit le nom du fichier correspondant au xlsx de l'entité
'puis on détruit le fichier sur le disque
fichier = ThisWorkbook.Path: If Right(fichier, 1) <> "\" Then fichier = fichier & "\"

fichier = fichier & P: Kill fichier
plage.AutoFilter Field:=4, Criteria1:=P 'on filtre la plage sur le pays p
wbk.Sheets(1).Cells.Clear 'on efface la feuille 1 du nouveau classeur
'on copie la plage filtrée dans le nouveau classeur
plage.SpecialCells(xlCellTypeVisible).Copy wbk.Sheets(1).Range("a1")

'on sauvegarde le nouveau classeur sous format
wbk.SaveAs Filename:=fichier, CreateBackup:=False
wbk.Sheets(1).Columns("A:O").AutoFit
Next P
wbk.Close savechanges:=False 'on ferme le nouveau classeur
.ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[linebich]

Re
Merci ta réaction Staple
D'accord
Option Explicit

Sub decouper_dans_fichier()
Dim plage As Range, t, collPays As New Collection, i&, wbk As Workbook, P, fichier

Application.ScreenUpdating = False
With Sheets("Fichier Import")
If .FilterMode Then .ShowAllData
Set plage = .Range("a1").CurrentRegion
plage.Sort key1:=.Cells(1, "D"), order1:=xlAscending, Header:=xlYes
t = plage.Columns(4)
On Error Resume Next
For i = 2 To UBound(t)
collPays.Add Item:=t(i, 1), Key:=t(i, 1)
Next i
Application.DisplayAlerts = False
Set wbk = Workbooks.Add
For i = wbk.Sheets.Count To 2 Step -1: Sheets(i).Delete: Next
For Each P In collPays

fichier = ThisWorkbook.Path: If Right(fichier, 1) <> "\" Then fichier = fichier & "\"

fichier = fichier & P:
plage.AutoFilter Field:=4, Criteria1:=P
wbk.Sheets(1).Cells.Clear

plage.SpecialCells(xlCellTypeVisible).Copy wbk.Sheets(1).Range("a1")


wbk.SaveAs Filename:=fichier, CreateBackup:=False

Next P
wbk.Close savechanges:=False
.ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[Staple1600]

Re

Pour utiliser les balises BBCODE, suivre les conseils qu'on on peut lire dans ma signature

 

[Staple1600]

Re

C'est ici qu'il faut modifier ta macro
plage.SpecialCells(xlCellTypeVisible).Copy wbk.Sheets(1).Range("a1")
pour pouvoir récupérer le format
Utilises l'enregistreur de macros (en faisant un copier/coller) pour obtenir la bonne syntaxe

 

[linebich]

Re j'ai pensé a cette solution mais l'enregistreur me donne la syntaxe
Paste:=xlPasteColumnWidths
et au niveau du code la syntaxe utilisé c'est celle copy et destination je ne sais pas comment est ce que je peux integrer cette propriété de collage au niveau de
plage.SpecialCells(xlCellTypeVisible).Copy wbk.Sheets(1).Range("a1")

 

[Staple1600]

Re

If suffisait de remplacer cette ligne* par ces trois lignes

plage.SpecialCells(xlCellTypeVisible).Copy
wbk.Sheets(1).Cells(1).PasteSpecial xlPasteAllUsingSourceTheme
wbk.Sheets(1).Cells(1).PasteSpecial xlPasteColumnWidths

Je te laisse faire le test

*: celle que j'ai isolé dans le message#5

 

[linebich]

Re , Malheureusement j’ai testé , le résultat des fichiers est vide
il copy donc pas les données

 

[Staple1600]

Re

Tu peux poster le code tel que tu l'as modifié, stp ?

 

[linebich]

Re


Option Explicit

Sub decouper_dans_fichier()
Dim plage As Range, t, collPays As New Collection, i&, wbk As Workbook, P, fichier

Application.ScreenUpdating = False
With Sheets("Fichier Import")
If .FilterMode Then .ShowAllData
Set plage = .Range("a1").CurrentRegion
plage.Sort key1:=.Cells(1, "D"), order1:=xlAscending, Header:=xlYes
t = plage.Columns(4)
On Error Resume Next
For i = 2 To UBound(t)
collPays.Add Item:=t(i, 1), Key:=t(i, 1)
Next i
Application.DisplayAlerts = False
Set wbk = Workbooks.Add
For i = wbk.Sheets.Count To 2 Step -1: Sheets(i).Delete: Next
For Each P In collPays

fichier = ThisWorkbook.Path: If Right(fichier, 1) <> "\" Then fichier = fichier & "\"

fichier = fichier & P: Kill fichier
plage.AutoFilter Field:=4, Criteria1:=P
wbk.Sheets(1).Cells.Clear

plage.SpecialCells(xlCellTypeVisible).Copy
wbk.Sheets(1).Cells(1).PasteSpecial xlPasteAllUsingSourceTheme
wbk.Sheets(1).Cells(1).PasteSpecial xlPasteColumnWidths




wbk.SaveAs Filename:=fichier, CreateBackup:=False

Next P
wbk.Close savechanges:=False
.ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[linebich]

j'ai une remarque malgré les tableau sont vide chaque fichier il est sous la mise en forme de la base globale et avec le nombre correcte de ligne approprié au filtre appliqué a chaque paye il manque que les données de ce paye
par exemple un fichie France doit contenir 5 ligne le resultat je trouve un tableau avec mise en forme adéquate bordure de 5 ligne mais pas de données dedans

 

[Staple1600]

Bonsoir le fil, linebich

J'ai modifié ton code comme suit
(test OK sur Excel 2010 (PC du boulot))

Sub decouper_dans_fichierII()
Dim plage As Range, t, collPays As New Collection, i&, wbk As Workbook, P, fichier
Application.ScreenUpdating = False 'on fige l'écran
fichier = ThisWorkbook.Path & "\"
With Sheets("Fichier Import")
If .FilterMode Then .ShowAllData 'si filtre alors on affiche tout
Set plage = .Range("a1").CurrentRegion 'plage est la plage des données source
plage.Sort key1:=.Cells(1, "D"), order1:=xlAscending, Header:=xlYes 'Tri de la plage selon le pays
t = plage.Columns(4) 'transfert dans le tableau t de la colonne des entité de la plage
On Error Resume Next ' si erreur (pays déjà dans la collection collPays), on continue
For i = 2 To UBound(t) 'boucle sur tous les pays de la plage (tableau t)
collPays.Add Item:=t(i, 1), Key:=t(i, 1) 'on ajoute le pays dans la collection collPays
Next i
Application.DisplayAlerts = False 'on se dispense des messages d'alerte
Set wbk = Workbooks.Add(xlWBATWorksheet) 'on ajoute un nouveau classeur avec une seule feuille
For Each P In collPays
plage.AutoFilter Field:=4, Criteria1:=P 'on filtre la plage sur le pays p
''on copie la plage filtrée dans le nouveau classeur
wbk.Sheets(1).Cells.Clear
plage.SpecialCells(xlCellTypeVisible).Copy
wbk.Sheets(1).Cells(1).PasteSpecial xlPasteColumnWidths
wbk.Sheets(1).Cells(1).PasteSpecial xlPasteAll
wbk.SaveAs Filename:=fichier & P
Next P
wbk.Close savechanges:=True
Set wbk = Nothing
.ShowAllData
End With
End Sub

 

[linebich]

Bonsoir staple Oui ça marche très bien je suis desolé pour le retard je viens de voir votre réponse et merci à vous