每個工作簿中的一張表格需要保存爲CSV

Question

我有兩個文件夾，分別爲2015和2016，在每個文件夾中，有12個子文件夾作爲月份，每個月份文件夾中有許多excel文件。所以例如從2015年的文件夾 - > 8月15日文件夾 - > PC Aug15.xlsb - >數據（圖紙名稱） 我需要這張表導出爲CSV並保存爲Aug15.CSV在一個新的路徑。

這樣我需要8月15日至7月16日的數據。我該怎麼做。請幫助

嘗試使用下面的代碼，但不知道我怎麼需要指明的是我只需要一個名爲「數據」

Sub SaveToCSVs() 
    Dim fDir As String 
    Dim wB As Workbook 
    Dim wS As Worksheet 
    Dim fPath As String 
    Dim sPath As String 
    fPath = "C:\temp\pydev\" 
    sPath = "C:\temp\" 
    fDir = Dir(fPath) 
    Do While (fDir <> "") 
     If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then 
      On Error Resume Next 
      Set wB = Workbooks.Open(fPath & fDir) 
      For Each wS In wB.Sheets 
       wS.SaveAs sPath & wS.Name, xlCSV 
      Next wS 
      wB.Close False 
      Set wB = Nothing 
     End If 
     fDir = Dir 
     On Error GoTo 0 
    Loop 
End Sub 

Answer 1

我明白你的代碼是否正確，從目標文件夾中讀取所有的文件，紙張問題是，你只需要提取一個Sheet名爲每個文件Data，所以如果是這樣的話試試這個：

編輯只包括選定的列提取！

方法：複製目標工作

Sub SaveToCSVs() 
Const kWshName As String = "Data" 
Dim sPathInp As String, sPathOut As String 
Dim sPathFile As String, sCsvFile As String 
Dim WbkSrc As Workbook, WshSrc As Worksheet 
Dim WbkCsv As Workbook, WshCsv As Worksheet 
Dim rData As Range 

    sPathInp = "C:\temp\pydev\" 
    sPathOut = "C:\temp\" 
    sPathFile = Dir(sPathInp) 

    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    Do While (sPathFile <> "") 
     If Right(sPathFile, 4) = ".xls" Or Right(sPathFile, 5) = ".xlsx" Then 

      Rem Initialize Objects 
      Set WbkSrc = Nothing 
      Set WshSrc = Nothing 

      Rem Set Objects 
      On Error Resume Next 
      Set WbkSrc = Workbooks.Open(sPathInp & sPathFile) 
      If Not (WbkSrc Is Nothing) Then 
       Set WshSrc = WbkSrc.Sheets(kWshName) 

       If Not (WshSrc Is Nothing) Then 
        On Error GoTo 0 

        Rem Set Csv Filename 
        sCsvFile = Left(sPathFile, -1 + InStrRev(sPathFile, ".")) 
        sCsvFile = sCsvFile & " - " & kWshName 

        Rem Calculate, Unhide Rows & Columns & Copy Data Sheet 
        With WshSrc 
         .Calculate 
         .Cells.EntireRow.Hidden = False 
         .Cells.EntireColumn.Hidden = False 
         .Copy 
        End With 
        Set WshCsv = ActiveSheet 

        Rem Delete All Other Columns 
        With Range(WshCsv.Cells(1), WshCsv.UsedRange.SpecialCells(xlLastCell)) 
         .Value = .Value 
         Set rData = Union(Columns("A"), Columns("P"), Columns("AC")) 
         rData.EntireColumn.Hidden = True 
         .SpecialCells(xlCellTypeVisible).EntireColumn.Delete 
         rData.EntireColumn.Hidden = False 
        End With 

        Rem Save as Csv 
        WshCsv.SaveAs Filename:=sPathOut & sCsvFile, FileFormat:=xlCSV 
        WshCsv.Parent.Close 
        WbkSrc.Close 

     End If: End If: End If 

     sPathFile = Dir 
     On Error GoTo 0 

    Loop 

    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.EnableEvents = True 

    End Sub 

方法：打開工作簿爲只讀

Sub SaveToCSVs() 
Const kWshName As String = "Data" 
Dim sPathInp As String 
Dim sPathOut As String 
Dim sPathFile As String 
Dim sCsvFile As String 
Dim WbkSrc As Workbook 
Dim WshSrc As Worksheet 
Dim rData As Range 

    sPathInp = "C:\temp\pydev\" 
    sPathOut = "C:\temp\" 
    sPathFile = Dir(sPathInp) 

    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    Do While (sPathFile <> "") 
     If Right(sPathFile, 4) = ".xls" Or Right(sPathFile, 5) = ".xlsx" Then 

      Rem Initialize Objects 
      Set WbkSrc = Nothing 
      Set WshSrc = Nothing 

      Rem Set Objects 
      On Error Resume Next 
      Set WbkSrc = Workbooks.Open(Filename:=sPathInp & sPathFile, ReadOnly:=True) 
      If Not (WbkSrc Is Nothing) Then 
       Set WshSrc = WbkSrc.Sheets(kWshName) 

       If Not (WshSrc Is Nothing) Then 
        On Error GoTo 0 

        Rem Set Csv Filename 
        sCsvFile = Left(sPathFile, -1 + InStrRev(sPathFile, ".")) 
        sCsvFile = sCsvFile & " - " & kWshName 

        Rem Calculate, Unhide Rows & Columns & Copy Data Sheet 
        With WshSrc 
         .Calculate 
         .Cells.EntireRow.Hidden = False 
         .Cells.EntireColumn.Hidden = False 

         Rem Delete All Other Columns 
         With Range(.Cells(1), .UsedRange.SpecialCells(xlLastCell)) 
          .Value = .Value 
          Set rData = Union(Columns("A"), Columns("P"), Columns("AC")) 
          rData.EntireColumn.Hidden = True 
          .SpecialCells(xlCellTypeVisible).EntireColumn.Delete 
          rData.EntireColumn.Hidden = False 

        End With: End With 

        Rem Save as Csv 
        WshSrc.SaveAs Filename:=sPathOut & sCsvFile, FileFormat:=xlCSV 
        WbkSrc.Close 

     End If: End If: End If 

     sPathFile = Dir 
     On Error GoTo 0 

    Loop 

    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.EnableEvents = True 

    End Sub