Boucle Macro VBA pour renommer er enregistrer [Résolu/Fermé]

Signaler
Messages postés
9
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
25 septembre 2019
-
Messages postés
9
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
25 septembre 2019
-
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

1 réponse

Messages postés
6868
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
7 août 2020
535
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


Messages postés
9
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
25 septembre 2019

Merci beaucoup
ça marche.