XL 2016 Code VBA pour copier/coller formats, liste et formules

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Mln77

XLDnaute Nouveau
Bonjour,

Je souhaiterais que mes dossiers soient crées en reprenant le même format, listes déroulante et formules que mon fichier initial.
Ci-dessous ma macro actuelle :
Merci d'avance pour votre aide

Option Explicit

Dim tablo, dico, i, j, k, t, ln, v(), fdep, f

Sub CréerLesDossiers()

tablo = Range(Cells(1, 1), Cells(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
Set dico = CreateObject("Scripting.Dictionary")

Set fdep = ActiveSheet
Sheets.Add
Set f = ActiveSheet
fdep.Select

For i = 2 To UBound(tablo, 1)
dico(tablo(i, 1)) = ""
Next i

k = dico.keys
For i = 0 To dico.Count - 1
'MsgBox k(i)
ln = 0
For t = 2 To UBound(tablo, 1)
If k(i) = tablo(t, 1) Then
ReDim Preserve v(UBound(tablo, 2), ln + 1)
For j = 1 To UBound(tablo, 2)
v(j - 1, ln) = tablo(t, j)
Next j
ln = ln + 1
End If
Next t

f.Cells.Clear
Rows("1:1").Copy f.Range("A1")
f.Range("A2").Resize(UBound(v, 2), UBound(v, 1)) = Application.Transpose(v)
Application.DisplayAlerts = False
f.Copy

With ActiveWorkbook

.SaveAs ThisWorkbook.Path & "\" & k(i)
.Close
End With
Next i

f.Cells.Clear
f.Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
MsgBox "Travail terminé."
End Sub
 
Re,

Merci pour ton retour, mais l'objectif est que je n'ai pas à remettre tout au bon format puisque j'ai 20 fichiers au total.
Si je comprends bien, mon code actuel ne peut pas être adapté pour prendre en compte la notion de copiage du format. Y aurait-il un autre code possible du coup ? Le code actuel créer 1 fichier par société (colonne 1).

Encore merci
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
599
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
79
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
503
  • Question Question
Microsoft 365 VBA Transpose
Réponses
11
Affichages
754
Réponses
3
Affichages
464
Réponses
33
Affichages
3 K
Retour