Utilisation de vba pour copier tout le contenu d'un classeur dans un fichier csv

Question

J'ai essayé de créer un script vba dans Excel pour copier le contenu de TOUS les fichiers xlsx d'un dossier dans des fichiers cvs.

J'utilisé comme aide: http://www.ozgrid.com/VBA/2007-filesearch-alternative.htm

et a créé le script suivant:

Sub CopySameSheetFrmWbs() 
Dim wbOpen As Workbook 
Dim wbNew As Workbook 

Const strPath As String = "C:\test\" 
Dim strExtension As String 

'Comment out the 3 lines below to debug 
Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
On Error Resume Next 

ChDir strPath 
strExtension = Dir("*.xlsx") 

     Do While strExtension <> "" 
      Set wbOpen = Workbooks.Open(strPath & strExtension) 
      Set wbNew = Workbooks.Add 
      wbNew.SaveAs Filename:="C:\test\copiedFile", FileFormat:=xlCSV 

      wbOpen.Sheets(Sheets.Count).Copy 
      wbNew.Sheets(Sheets.Count).PasteSpecial 

      strExtension = Dir 
     Loop 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 
On Error GoTo 0 
End Sub 

Je suppose que je ne comprends pas et qui est la raison pour laquelle il ne fonctionne pas. Ce code crée un fichier csv vide et crée des classeurs bizarres chaque fois que le script est exécuté.

Pouvez-vous s'il vous plaît aidez-moi?

Answer 1

Actuellement votre code enregistre dans un fichier vide sans d'abord copier les feuilles.

Changer votre code à ceci:

Do While strExtension <> "" 
      Set wbOpen = Workbooks.Open(strPath & strExtension) 
      Set wbNew = Workbooks.Add 
      wbOpen.Sheets(Sheets.Count).Copy 
      wbNew.Sheets(Sheets.Count).PasteSpecial 

      strExtension = Dir 


      wbNew.SaveAs Filename:="C:\test\copiedFile", FileFormat:=xlCSV 

Loop 

Answer 2

Ok, j'ai trouvé une solution de travail pour moi:

Sub CopySameSheetFrmWbs() 
Dim wbOpen As Workbook 
Dim wbNew As Workbook 

Const strPath As String = "C:\vba_test\" 
Dim strExtension As String 

'Comment out the 3 lines below to debug 
Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
On Error Resume Next 

ChDir strPath 
strExtension = Dir("*.xlsx") 

     Do While strExtension <> "" 
      Set wbOpen = Workbooks.Open(strPath & strExtension) 

      With wbOpen 
       .SaveAs (Left(wbOpen.Name, InStr(wbOpen.Name, ".") - 1)), FileFormat:=xlCSV 
       strExtension = Dir 
      End With 
     Loop 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 
On Error GoTo 0 
End Sub