Bonjour
Une fois de plus je me retrouve coincé et je viens donc faire appels à vos services
Je souhaiterais faire une macro qui me permette de mettre en forme un fichier au format .csv en partant de plusieurs fichiers .xls
Je possède déjà une macro qui me fait le traitement sur un fichier mais j'aimerais l'adapter pour que celle-ci traite l'intégralité de mes fichiers
Je voudrais donc que ma macro fasse ce traitement sur chacun des fichiers au format .xls et que celle-ci m'enregistre le résultat au format .csv pour que je puisse par la suite l'importer dans ma base de données.
En espérant que quelqu'un puisse m'aider
Cordialement
Option Explicit
Sub TraitementCarteLucent()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim Vpath As String
'
Vpath = ChoisirDossier
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(Vpath)
' Pour chaque fichier trouvé dans le dossier
For Each FileItem In SourceFolder.Files
Application.Workbooks.Open FileItem
Columns("A:A").Cut 'Destination:=Columns("H:H")
Columns("C:C").Insert Shift:=xlToRight
'Columns("B:B").Cut Destination:=Columns("A:A")
Columns("H:H").Cut Destination:=Columns("B:B")
Columns("C:C").Insert Shift:=xlToRight
Columns("G:G").Cut Destination:=Columns("D:D")
Columns("H:H").Cut Destination:=Columns("G:G")
Columns("D:D").NumberFormat = "0"
Rows("1:1").Delete Shift:=xlUp
ActiveWorkbook.Close
Next FileItem
' Effacer les variables objet
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Private Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
chemin = ""
End If
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
' Renvoyer le chemin dans la fonction
ChoisirDossier = chemin
End Function
ATTENTION toute fois à tes "cut" et "paste" qui me paraissent pour certains, illogiques
Tous les fichiers à traiter sont ouverts ?
si non, où sont-ils stockés, pour les ouvrir ?
chaque fichier n'a qu'une feuille de calcul ?
le format CSV d'export est avec séparateur ";" ou "," ?
Avec plus de précisions, tu aurais certainement déjà eu une réponse
Bing : Bonjour Bruno
J'ai l'air de quoi, à raler maintenant
Bonjour
Tout d'abord merci à vous deux de prendre le temps de m'aider
Bruno je viens de tester ton code mais en fait il ne fait pas tout à fait ce que je voudrais
Je vais donc comme me le conseille toto essayer de donner des précisions
Tous les fichiers à traiter sont ouverts ?
si non, où sont-ils stockés, pour les ouvrir ?
chaque fichier n'a qu'une feuille de calcul ?
le format CSV d'export est avec séparateur ";" ou "," ?
Concernant les fichiers à traiter ils ne sont pas ouverts, en revanche ils sont tous au format Excel et sont tous dans le dossier où sera la macro
Il est donc simple d'en connaître le chemin, je pense que ce sera cela
Code:
Path = ThisWorkbook.Path & "\"
Chaque fichier ne dispose que d'une feuille de calcul.
Et concernant le format CSV d'export j'aimerais que les séparateurs soit des ";"
Petite précision en plus pour aider Bruno
En gros la macro ouvre le premier fichier .xls dans le répertoire courant
Dans ce fichier elle copie le contenu dans un nouveau fichier, en respectant l'ordre suivant:
Colonne 1 -> Circuit Pack
Colonne 2 -> Ne Name
Colonne 3 -> Colonne a laissé vide
Colonne 4 -> Com Code
Colonne 5 -> Actual Item Code
Colonne 6 -> Interchangeability Marker
Colonne 7 -> Serial Number
On supprime la première ligne contenant les noms de colonne
Puis on ferme le premier fichier .xls
On ouvre le fichier .xls suivant et on copie les données à la suite de celle déjà copié, on supprime la ligne avec les noms de colonne
Et ainsi de suite, pour au final enregistrer un fichier au format CSV contenant les données de tous les autres fichiers
Concernant la recherche de tout les fichiers je sais déjà le faire
Code:
Sub MiseEnForme()
Dim LePath As String
Dim Fich As String, X As String
Application.ScreenUpdating = False
LePath = ThisWorkbook.Path & "\"
Fich = Dir(LePath & "*.ri")
Do While Fich <> ""
X = LePath & Fich
Open X For Input As #1
Close #1
Fich = Dir
Flag = False
Loop
End Sub
En revanche je n'arrive pas à faire le traitement sur les fichiers
Peut-être faudrait-il d'abord copier tout les fichiers dans une seule et même feuille et ensuite faire le traitement
(il manque juste l'enregistrement en CSV a priori)
Code:
Sub TraitementCarteLucent()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim Vpath As String
Dim DestWkb As Workbook, Ligne As Long
Application.ScreenUpdating = False
Ligne = 1
Set DestWkb = Workbooks.Add
Vpath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(Vpath)
' Pour chaque fichier trouvé dans le dossier
For Each FileItem In SourceFolder.Files
If UCase(FileItem) Like "*.XLS" Then
Application.Workbooks.Open FileItem
Columns("A:A").Cut 'Destination:=Columns("H:H")
Columns("C:C").Insert Shift:=xlToRight
'Columns("B:B").Cut Destination:=Columns("A:A")
Columns("H:H").Cut Destination:=Columns("B:B")
Columns("C:C").Insert Shift:=xlToRight
Columns("G:G").Cut Destination:=Columns("D:D")
Columns("H:H").Cut Destination:=Columns("G:G")
Columns("D:D").NumberFormat = "0"
Rows("1:1").Delete Shift:=xlUp
ActiveWorkbook.ActiveSheet.UsedRange.Copy DestWkb.ActiveSheet.Range("A" & Ligne)
Ligne = DestWkb.ActiveSheet.Range("A65536").End(xlUp).Row + 1
ActiveWorkbook.Close False
End If
Next FileItem
Application.ScreenUpdating = True
' Effacer les variables objet
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Tout d'abord merci tototiti
Par contre le traitement qui se fait n'est pas exactement celui que je veux
Que dois-je modifier pour arriver à
Colonne 1 -> Circuit Pack
Colonne 2 -> Ne Name
Colonne 3 -> Colonne a laissé vide
Colonne 4 -> Com Code
Colonne 5 -> Actual Item Code
Colonne 6 -> Interchangeability Marker
Colonne 7 -> Serial Number
Sub TraitementCarteLucent()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim Vpath As String
Dim DestWkb As Workbook, Ligne As Long
Application.ScreenUpdating = False
Ligne = 1
Set DestWkb = Workbooks.Add
Vpath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(Vpath)
' Pour chaque fichier trouvé dans le dossier
For Each FileItem In SourceFolder.Files
If UCase(FileItem) Like "*.XLS" Then
Application.Workbooks.Open FileItem
Columns("B:B").Cut
Columns("A:A").Insert Shift:=xlToRight
Columns("F:F").Cut
Columns("C:C").Insert Shift:=xlToRight
Columns("D:D").Delete Shift:=xlToLeft
Columns("G:G").Delete Shift:=xlToLeft
Columns("C:C").Insert Shift:=xlToRight
Rows("1:1").Delete Shift:=xlUp
ActiveWorkbook.ActiveSheet.UsedRange.Copy DestWkb.ActiveSheet.Range("A" & Ligne)
Ligne = DestWkb.ActiveSheet.Range("A65536").End(xlUp).Row + 1
ActiveWorkbook.Close False
End If
Next FileItem
Application.ScreenUpdating = True
' Effacer les variables objet
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Merci tototiti
En essayant de comprendre la logique j'ai réussi à traiter les fichiers comme je voulais
Je mets le code car il reste deux petits hic
Code:
Sub TraitementCarteLucent()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim Vpath As String
Dim DestWkb As Workbook, Ligne As Long
Application.ScreenUpdating = False
Ligne = 1
Set DestWkb = Workbooks.Add
Vpath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(Vpath)
' Pour chaque fichier trouvé dans le dossier
For Each FileItem In SourceFolder.Files
If UCase(FileItem) Like "*.XLS" Then
Application.Workbooks.Open FileItem
Columns("B:B").Cut Destination:=Columns("H:H")
Columns("A:A").Cut Destination:=Columns("B:B")
Columns("H:H").Cut Destination:=Columns("A:A")
Columns("C:C").Insert Shift:=xlToRight
Columns("G:G").Cut Destination:=Columns("D:D")
Columns("H:H").Cut Destination:=Columns("G:G")
Columns("D:D").NumberFormat = "0"
Rows("1:1").Delete Shift:=xlUp
ActiveWorkbook.ActiveSheet.UsedRange.Copy DestWkb.ActiveSheet.Range("A" & Ligne)
Ligne = DestWkb.ActiveSheet.Range("A65536").End(xlUp).Row + 1
ActiveWorkbook.Close False
End If
Next FileItem
Application.ScreenUpdating = True
' Effacer les variables objet
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Vpath & "\" & "carte.csv", FileFormat:=xlCSV
ActiveWorkbook.Close
End Sub
1er petit beug: Columns("D").NumberFormat = "0" ne fonctionne pas correctement, je m'explique, j'obtiens un nombre au format 108244104 006 alors qu'il devrait être sous la forme 108244104006
2eme petit beug: Mon fichier est bien enregistré dans mon répertoire au format csv mais quand je l'ouvre les séparateurs sont des virgules et du coup toutes les données sont condensés dans une seul et même colonne
c'est sans doute qu'il ne le considère pas comme un nombre
Il faut certainement remplacer les espaces par rien dans la colonne
2eme petit beug: Mon fichier est bien enregistré dans mon répertoire au format csv mais quand je l'ouvre les séparateurs sont des virgules et du coup toutes les données sont condensés dans une seul et même colonne
Merci tototiti
Du coup j'avais trouvé le Local:=True dans un post du forum
Et concernant le format du nombre ce n'est pas très important je le laisse finalement sous la forme 108 244 104 006
Encore merci pour le temps passé à résoudre mon problème
Chapeau l'artiste