各ワークブックの1枚をCSVとして保存する

Question

2015と2016の2つのフォルダがあります。各フォルダに12個のサブフォルダがあり、毎月フォルダには多数のExcelファイルがあります。たとえば、2015フォルダ→8月15日フォルダ→PC Aug15.xlsb→データ（シート名） このシートがCSV形式でエクスポートされ、Aug15.CSVとして新しいパスに保存される必要があります。

このように私は8月15日〜7月16日のデータが必要です。どうすればいいですか？私はあなたのコードが正しく、ターゲットフォルダからすべてのファイルを読み込んでいることを理解したコードの下に使用しようと

を助けるが、私はちょうど「データ」という名前のシートが必要であることを私はspeicfy方法を知ってはいけない

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

してくださいONLY選択した列の抽出を含めるように

EDITを：問題は、あなたが唯一のそのような場合にはこれを試すので、それぞれのファイルからDataという名前の1 Sheetを抽出したいということです！

方法：対象のワークシートをコピーする

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