Boucle Macro VBA pour renommer er enregistrer

Résolu/Fermé
jannot1986 Messages postés 9 Date d'inscription dimanche 20 janvier 2019 Statut Membre Dernière intervention 25 septembre 2019 - 29 avril 2019 à 03:30
jannot1986 Messages postés 9 Date d'inscription dimanche 20 janvier 2019 Statut Membre Dernière intervention 25 septembre 2019 - 29 avril 2019 à 20:10
Bonjour à tous,
J'ai un répertoire contenant 30 fichiers Excel. Chacun de ces fichiers contient des données en bloc séparé par des virgules.
Je voudrais creer une boucle Macro qui va ouvrir le 1er fichier du répertoire, convertir en colonne et enregistrer les données convertis sous un nom (par exemple fichier1). Ensuite le 2nd fichier du repertoire et l'enregistrer sous un autre nom (Fichier2) et ainsi de suite pour le 3è et cela jusqu'à 30.

Pour l'instant j'arrive à creer la boucle que j'ai crée ouvre le 1er fichier du repertoire, effectue le traitement puis enregistre bien sous le nom fichier1,
seul bémol c'est que il effectue le traitement du 2nd et l'enregistre sous le même non fichier1 écrasant ainsi les informations du 1er fichier; et ainsi de suite.

Je voudrais si possible introduire un code qui, si le fichier1 existe dans le repertoire de destination, le renommer en fichier2, et ainsi de suite fichier3, fichier4, etc.

Voici le code Macro que j'ai pour l'instant.

Option Explicit
'Déclaration des Variables
Dim Repertoire As String
Dim LigneTotal As Long
Dim Derligne As Long


Sub Operation_remarquables_eumm()
'

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("conversion").Visible = True
Worksheets("conversion").Select
Rows("1:1000000").Select
Selection.Clear


ChDir "C:\Users\JANNOT\Desktop\operation remarquables EUMM\ETATS EUMM"
Repertoire = Dir("C:\Users\JANNOT\Desktop\operation remarquables EUMM\ETATS EUMM\*.xlsx")

While Len(Repertoire) > 0
Workbooks.Open "C:\Users\JANNOT\Desktop\operation remarquables EUMM\ETATS EUMM\" & Repertoire
Columns("A:A").Select
Selection.Copy
Workbooks("Macro traitement operations remarquables eumm.xlsm").Activate
Worksheets("conversion").Visible = True
Worksheets("conversion").Select
ActiveSheet.Paste
Columns("A:A").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1)), _
TrailingMinusNumbers:=True
LigneTotal = ActiveSheet.UsedRange.Rows.Count - 2
Range("A2:Y" & LigneTotal).Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\JANNOT\Desktop\operation remarquables EUMM\conversion\fichier1.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Workbooks(Repertoire).Close
Repertoire = Dir
Wend

End Sub


Merci d'avance
A voir également:

1 réponse

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
29 avril 2019 à 10:41
Bonjour,

comme ceci:

Option Explicit
'Déclaration des Variables
Dim Repertoire As String
Dim LigneTotal As Long
Dim Derligne As Long
Dim i As Integer
Sub Operation_remarquables_eumm()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("conversion").Visible = True
Worksheets("conversion").Select
Rows("1:1000000").Select
Selection.Clear
i = 1
ChDir "C:\Users\JANNOT\Desktop\operation remarquables EUMM\ETATS EUMM"
Repertoire = Dir("C:\Users\JANNOT\Desktop\operation remarquables EUMM\ETATS EUMM\*.xlsx")

While Len(Repertoire) > 0
Workbooks.Open "C:\Users\JANNOT\Desktop\operation remarquables EUMM\ETATS EUMM\" & Repertoire
Columns("A:A").Select
Selection.Copy
Workbooks("Macro traitement operations remarquables eumm.xlsm").Activate
Worksheets("conversion").Visible = True
Worksheets("conversion").Select
ActiveSheet.Paste
Columns("A:A").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1)), _
TrailingMinusNumbers:=True
LigneTotal = ActiveSheet.UsedRange.Rows.Count - 2
Range("A2:Y" & LigneTotal).Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\JANNOT\Desktop\operation remarquables EUMM\conversion\fichier" & i & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Workbooks(Repertoire).Close
Repertoire = Dir
i = i + 1
Wend
End Sub


0
jannot1986 Messages postés 9 Date d'inscription dimanche 20 janvier 2019 Statut Membre Dernière intervention 25 septembre 2019
29 avril 2019 à 20:10
Merci beaucoup
ça marche.
0