Créer autant de fichier que de cellules différentes
Bonjour,
j'aimerai créer autant de fichier xlsm que j'ai de cellule différente dans l'onglet "Index" en colonne B et copier le contenu filtré lié à cette valeur dans un onglet Index avec l'entête.
Dans le cas présent, je dois obtenir :
2 fichiers : AUDI.xlsm et SEAT.xlsm
Dans AUDI.xlsm, je dois avoir
id_rgp NOMMAR NOMGRPMODPHA
MARQ_1 AUDI Q7 Ph.1 2006-03->2009-04
MARQ_1 AUDI Q5 2008-10->
Dans SEAT.xlsm, je dois avoir
id_rgp NOMMAR NOMGRPMODPHA
MARQ_2 SEAT INCA 1996-01->2004-12
MARQ_2 SEAT INCA 2005-01->2012-12
bonsoir,
une proposition de macro à tester
Sub creeclasseurauto()
Set wsi = Workbooks("test_MAR.xlsm").Worksheets("index")
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To dli
If marque = "" Then
marque = wsi.Range("B" & i)
Set wbm = Workbooks.Add
wbm.Worksheets(1).Name = marque
Set wsm = wbm.Worksheets(1)
wsi.Rows(1).Copy wsm.Range("A1")
lf = i
End If
If marque <> wsi.Range("B" & i) Or i = dli Then
wsi.Rows(lf & ":" & i - 1).Copy wsm.Range("a" & 2)
wbm.SaveAs Filename:=marque & ".xlsx"
wbm.Close
marque = ""
End If
Next i
Set wsi = Nothing
End SubMerci c'est nickel
En fait j'ai un autre souci. Je voulais recopier aussi les 2 feuilles GAB_1 et GAB_2 (modèles) dans les fichiers de sorties et derrière la feuille Index et je n'arrive pas à le faire.
Bonjour
En modifiant légèrement la macro de H2so4
A tester
Encore merci
Bonjour
En fait je viens de m'apercevoir qu'au moment de la copie dans le nouveau classeur, une ligne était supprimée.
Je suis passé en mode débogage et j'ai l'impression que le problème vient de la variable I à laquelle on retire 1.
wsi.Rows(lf & ":" & I - 1).Copy wsm.Range("a" & 2).
Sub creeclasseurauto()
Dim chem As String 'déclare la variable chem (Chemin)
chem = ThisWorkbook.Path & "\" 'définit la variable chem
Dim wb As ThisWorkbook
Dim wbm As Workbook
Set wsi = ThisWorkbook.Worksheets("Index")
With wsi
With .Range("A:K")
.Sort Key1:=wsi.Range("H2"), Order1:=xlAscending, Header:=xlYes
.Sort Key1:=wsi.Range("B2"), Order1:=xlAscending, _
Key2:=wsi.Range("A2"), Order2:=xlAscending, _
Key3:=wsi.Range("F2"), Order3:=xlAscending, Header:=xlYes
End With
End With
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To dli
If marque = "" Then
marque = wsi.Range("B" & I)
Sheets(Array("GAB_1", "GAB_2")).Copy
Set wbm = ActiveWorkbook 'Workbooks.Add
wbm.Sheets.Add(Before:=wbm.Sheets(1)).Name = "Index"
Set wsm = wbm.Worksheets(1)
wsi.Rows(1).Copy wsm.Range("A1")
lf = I
End If
If marque <> wsi.Range("B" & I) Or I = dli Then
wsi.Rows(lf & ":" & I - 1).Copy wsm.Range("a" & 2)
'Worksheets(Array("GAB_1", "GAB_2")).Copy
wbm.SaveAs Filename:=chem & marque & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 'renommer
wbm.Close
marque = ""
End If
Next I
Set wsi = Nothing
End SubSi je retire -1 cela fonctionne bien, toutes mes lignes sont recopiées dans les fichiers des Marques BMW et HONDA
Lorsque je lance la macro dans chaque Marque; j'ai une erreur liée au tri des feuilles
Cordialement
bonjour,
l'erreur vient probablement de l'instruction surlignée, que j'ai corrigée.
El Blobo a écrit :Bonjour
En fait je viens de m'apercevoir qu'au moment de la copie dans le nouveau classeur, une ligne était supprimée.
Je suis passé en mode débogage et j'ai l'impression que le problème vient de la variable I à laquelle on retire 1.
wsi.Rows(lf & ":" & I - 1).Copy wsm.Range("a" & 2).
Sub creeclasseurauto() Dim chem As String 'déclare la variable chem (Chemin) chem = ThisWorkbook.Path & "\" 'définit la variable chem Dim wb As ThisWorkbook Dim wbm As Workbook Set wsi = ThisWorkbook.Worksheets("Index") With wsi With .Range("A:K") .Sort Key1:=wsi.Range("H2"), Order1:=xlAscending, Header:=xlYes .Sort Key1:=wsi.Range("B2"), Order1:=xlAscending, _ Key2:=wsi.Range("A2"), Order2:=xlAscending, _ Key3:=wsi.Range("F2"), Order3:=xlAscending, Header:=xlYes End With End With dli = wsi.Range("A" & Rows.Count).End(xlUp).Row For I = 2 To dli If marque = "" Then marque = wsi.Range("B" & I) Sheets(Array("GAB_1", "GAB_2")).Copy Set wbm = ActiveWorkbook 'Workbooks.Add wbm.Sheets.Add(Before:=wbm.Sheets(1)).Name = "Index" Set wsm = wbm.Worksheets(1) wsi.Rows(1).Copy wsm.Range("A1") lf = I End If If marque <> wsi.Range("B" & I) Or I > dli Then wsi.Rows(lf & ":" & I - 1).Copy wsm.Range("a" & 2) 'Worksheets(Array("GAB_1", "GAB_2")).Copy wbm.SaveAs Filename:=chem & marque & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 'renommer wbm.Close marque = "" End If Next I Set wsi = Nothing End SubSi je retire -1 cela fonctionne bien, toutes mes lignes sont recopiées dans les fichiers des Marques BMW et HONDA
Lorsque je lance la macro dans chaque Marque; j'ai une erreur liée au tri des feuilles
Cordialement
Désolé,
mais cela ne fonctionne pas.
Je vois bien que c'est au niveau de la variable Lf ou I mais je ne comprends toujours pas.
De plus en mettant le ">" je n'ai plus d'enregistrement de ma feuille dans la marque Honda.
je n'ai plus ton fichier, je ne peux donc pas tester
mais j'ai oublié autre chose.
For I = 2 To dli+1J'ai intégré les 2 modifications
For I = 2 To dli + 1
et
If marque <> wsi.Range("B" & I) Or I > dli Then
Dans le dernier fichier créé (Honda.xlsm)
mais j'ai toujours le même problème, une seule ligne est supprimée. Lors de la macro, un tri est effectué et on fait un copie mais pour le dernier du dernier ORD (Honda.xlsm), sa 1re ligne n'est pas copiée
2104 HONDA CR-V II Ph.2 2004-10->2006-12 2004-10 2006-12 1 Ident 1 17826 [CR-V II BREAK 5P 10-2004->12-2006] 2.2CTDI 140 16V Turbo 4X4 (103kW) -N22A2- M6 3
Je te remercie de tes efforts, mais le code ne fonctionne toujours pas.
J'ai réduit la data pour essayer d'y voir plus clair
bonjour,
très étrange, chez moi ce code fonctionne très bien (en tout cas celui que je t'ai envoyé, celui que tu m'as remis pour tester ne contient pas la dernière version !)
je te renvoie le code qui fonctionne chez moi.
Eh oui autant pour moi. Tout marche à merveille
Avec les multiples essai j'ai du faire un mauvais copier coller.
Merci pour le temps passé
Un petit bonjour à la Belgique