Menu

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

Messages postés
6
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
30 avril 2019
- - Dernière réponse : jannot1986
Messages postés
6
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
30 avril 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
Afficher la suite 

Votre réponse

1 réponse

Messages postés
6051
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
24 mai 2019
365
0
Merci
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


jannot1986
Messages postés
6
Date d'inscription
dimanche 20 janvier 2019
Statut
Membre
Dernière intervention
30 avril 2019
-
Merci beaucoup
ça marche.
Commenter la réponse de cs_Le Pivert