每个工作簿中的一张表格需要保存为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