Boucle Macro VBA pour renommer er enregistrer
Résolu
jannot1986
Messages postés
9
Statut
Membre
-
jannot1986 Messages postés 9 Statut Membre -
jannot1986 Messages postés 9 Statut Membre -
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
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:
- Boucle Macro VBA pour renommer er enregistrer
- Audacity enregistrer son pc - Guide
- Renommer des fichiers en masse - Guide
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Renommer iphone - Guide
- Comment renommer quelqu'un sur instagram - Guide
1 réponse
Bonjour,
comme ceci:
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
ça marche.