ein Blatt aus jeder Arbeitsmappe muss als CSV gespeichert werden

Question

Ich habe zwei Ordner als 2015 und 2016, In jedem Ordner gibt es 12 Unterordner als Monate und jeden Monat Ordner hat viele Excel-Dateien. So zum Beispiel von 2015 Ordner -> 15. August Ordner -> PC Aug15.xlsb -> Daten (Blattname) Ich brauche dieses Blatt, um als CSV exportiert und als Aug15.CSV in einem neuen Pfad gespeichert werden.

So brauche ich Daten vom 15. August - 16. Juli. Wie kann ich das tun? Bitte helfen

Code unten verwenden Probieren, aber wissen nicht, wie ich speicfy, dass ich gerade Blatt muß den Namen „Data“

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

Ich verstehe, dass der Code korrekt alle Dateien aus dem Zielordner liest, die Problem ist, dass Sie nur eine SheetData aus jeder Datei mit dem Namen extrahieren möchten, so dass, wenn das der Fall ist versuchen Sie dies:

EDIT EXTRACTION nUR ausgewählten Spalten enthalten!

Methode: Kopieren Ziel Arbeitsblatt

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 

Methode: Öffnen Arbeitsmappe als Readonly

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