使用VBA将所有内容从一个工作簿复制到CSV文件

Question

I tried to create a vba script in excel in order to copy the content of ALL xlsx files in a folder into cvs files.

I used as help: http://www.ozgrid.com/VBA/2007-filesearch-alternative.htm

And created the following script:

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

I guess I just don't get it and that is why it is not working. This code creates an empty csv file and creates some weird workbooks everytime is run the script.

Can you please help me?

Answer 1

Ok, I found a working solution for me:

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

Answer 2

Currently your code saves to an empty file without copying the Sheets first.

Change your code to this:

 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