Dateien aus Pfad verarbeiten

Sub zusammenfassung() GetMoreSpeed True Dim wks As Worksheet, zrow As Double, ecol As Double, wkb As Workbook, B_Name As String Workbooks.Add ActiveWorkbook.SaveAs filename:="C:\Documents and Settings\...\Desktop\Zusammenfassung.xls", _ FileFormat:=xlNormal For Each wkb In Workbooks If InStr(1, wkb.Name, "Auswertung gelöschte") > 0 Then Workbooks("Zusammenfassung.xls").Worksheets.Add before:=Worksheets(1) B_Name = Left(wkb.Name, InStr(1, wkb.Name, ".") - 1) B_Name = Mid(B_Name, InStr(1, B_Name, "LS") + 3, 30) Workbooks("Zusammenfassung.xls").ActiveSheet.Name = B_Name For Each wks In wkb.Worksheets If wks.Name "Auswertung" Then With ActiveWorkbook.Worksheets(B_Name) zrow = .Range("A65536").End(xlUp).Row ecol = wks.Range("IV1").End(xlToLeft).Column wks.Range("A1:A1").Resize(, ecol).Copy Destination:=.Range("A1") .Range("A1").Offset(, ecol) = "Datum" wks.Range("A2:A30").Resize(, ecol).Copy .Range("A" & zrow + 1).PasteSpecial Paste:=xlPasteValues .Range("A" & zrow + 1).PasteSpecial Paste:=xlPasteFormats On Error Resume Next .Range("A" & zrow + 1 & ":A" & zrow + 29).Offset(, ecol).Value = CDate(wks. _ Name & "2010") On Error GoTo 0 .Columns("A:A").Resize(, ecol).AutoFit End With End If Next End If Next For Each wks In Worksheets If InStr(1, wks.Name, "Tabelle") > 0 Then wks.Delete End If Next GetMoreSpeed False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub zusammenfassung() GetMoreSpeed True Dim wks As Worksheet, zrow As Double, ecol As Double, wkb As Workbook, B_Name As String Dim sFile As String, sPfad As String sPfad = "c:\test\" Workbooks.Add ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\...\Desktop\Zusammenfassung.xls", _ _ FileFormat:=xlNormal sFile = Dir("Auswertung gelöschte" & "*.xls") Do While sFile "" Set wkb = Workbooks.Open(sPfad & sFile) Workbooks("Zusammenfassung.xls").Worksheets.Add before:=Worksheets(1) B_Name = Left(wkb.Name, InStr(1, wkb.Name, ".") - 1) B_Name = Mid(B_Name, InStr(1, B_Name, "LS") + 3, 30) Workbooks("Zusammenfassung.xls").ActiveSheet.Name = B_Name For Each wks In wkb.Worksheets If wks.Name "Auswertung" Then With ActiveWorkbook.Worksheets(B_Name) zrow = .Range("A65536").End(xlUp).Row ecol = wks.Range("IV1").End(xlToLeft).Column wks.Range("A1:A1").Resize(, ecol).Copy Destination:=.Range("A1") .Range("A1").Offset(, ecol) = "Datum" wks.Range("A2:A30").Resize(, ecol).Copy .Range("A" & zrow + 1).PasteSpecial Paste:=xlPasteValues .Range("A" & zrow + 1).PasteSpecial Paste:=xlPasteFormats On Error Resume Next .Range("A" & zrow + 1 & ":A" & zrow + 29).Offset(, ecol).Value = CDate(wks.Name & " _ 2010") On Error GoTo 0 .Columns("A:A").Resize(, ecol).AutoFit End With End If Next wkb.Close False sFile = Dir Loop For Each wks In Worksheets If InStr(1, wks.Name, "Tabelle") > 0 Then wks.Delete End If Next GetMoreSpeed False End Sub

Hallo Rudi,
jetzt hats geklappt. Ich hatte zwar noch eine Fehlermeldung, aber die hab ich selbst weg bekommen. Meine Referenzierung auf die einzelnen Workbooks/sheets ist wohl nicht ganz sauber, deswegen hatte der Code in die falsche Datei gegriffen.
Eine Frage noch zum Verständnis:
Mit der Do-Loop-Schleife komme ich nicht ganz klar. Der Befehl

sFile = Dir(sPfad & "Auswertung gelöschte" & "*.xls")

liest doch immer nur eine Datei ein (Zumindest wird mir im Debugging-Modus nur die erste Datei angezeigt)?! Wenn nun der Loop-Befehl kommt, um die nächste Datei einzulesen/zu öffnen, wird anscheinend diese Zeile wieder angesteuert. Müsste sie da nicht INNERHALB der Schleife stehen?
Auf jeden Fall noch mal ein großes Danke.
Gruß
David

Hallo,
Ordner Pfad noch anpassen.
kommt als Code in Modul1

Option Explicit 
 
 
Sub Suchmaschine() 
Dim FileArray() 
Dim LCount As Long 
Dim FNR As String 
 
'1.Parameter Area 
'2.Parameter Ordner, wo soll gesucht werden? 
'3.Parameter Datei,* als Platzhalter verwenden,Optional leer ist alle 
'4.Parameter mit Unterordner = True, Optional False ist ohne 
'5.Parameter Counter 
 
'Ordner Pfad anpassen 
ListFilesInFolder FileArray, "G:\1 Forum\Test_Ordner", "Auswertung gelöschte LS*.xls", False, LCount 
 
 
If LCount > 0 Then 
    zusammenfassung FileArray 
End If 
 
Erase FileArray 
End Sub 
 
Sub zusammenfassung(ByVal ArrFiles) 
Dim wks As Worksheet, zrow As Double, ecol As Double, wkb As Workbook, B_Name As String 
Dim nCount As Integer 
Dim oWB As Workbook, oSH As Worksheet, tmpWB As Workbook 
 
Set oWB = Workbooks.Add(1) 
 
''speichern aktivieren 
'oWB.SaveAs Filename:="C:\Documents and Settings\...\Desktop\Zusammenfassung.xls", FileFormat:=xlNormal 
 
With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .DisplayAlerts = False 
     
For nCount = Lbound(ArrFiles) To Ubound(ArrFiles) 
         
        Set oSH = oWB.Worksheets.Add(before:=oWB.Worksheets(1)) 
        oWB.Sheets(2).Delete 
        B_Name = Left(ArrFiles(nCount), InStr(1, ArrFiles(nCount), ".") - 1) 
        B_Name = Mid(B_Name, InStr(1, ArrFiles(nCount), "LS") + 3, 30) 
         
        oSH.Name = B_Name 
        Set tmpWB = Workbooks.Open(ArrFiles(nCount), ReadOnly:=True) 
         
        On Error Resume Next 
            Set wks = tmpWB.Worksheets("Auswertung") 
        On Error GoTo 0 
   
            If Not wks Is Nothing Then 
                With oSH 
                    zrow = .Cells(.Rows.Count, 1).End(xlUp).Row 
                    ecol = wks.Cells(1, wks.Columns.Count).End(xlToLeft).Column 
                    wks.Range("A1").Resize(, ecol).Copy Destination:=.Range("A1") 
                    .Range("A1").Offset(, ecol) = "Datum" 
                    wks.Range("A2:A30").Resize(, ecol).Copy 
                    .Range("A" & zrow + 1).PasteSpecial Paste:=xlPasteValues 
                    .Range("A" & zrow + 1).PasteSpecial Paste:=xlPasteFormats 
                    On Error Resume Next 
                    .Range("A" & zrow + 1 & ":A" & zrow + 29).Offset(, ecol).Value = wks.Name & " " & Year(Date) 
                    On Error GoTo 0 
                    .UsedRange.EntireColumn.AutoFit 
                End With 
            End If 
 
     
    Application.CutCopyMode = False 
    tmpWB.Close False 
Next nCount 
 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .DisplayAlerts = False 
End With 
 
End Sub

kommt als Code in Modul2

Option Explicit 
 
'Listet Files in Area 
Sub ListFilesInFolder(FileArray, SourceFolderName As String, Optional DateiFormat As String = "*.*", _
                        Optional IncludeSubfolders As Boolean = False, Optional LCount As Long = 0) 
 
Dim FSO As Object, SourceFolder As Object, SubFolder As Object 
Dim FileItem 
Dim Status As Integer 
  
 Set FSO = CreateObject("Scripting.FileSystemObject") 
  
 If FSO.FolderExists(SourceFolderName) Then 
     Set SourceFolder = FSO.GetFolder(SourceFolderName) 
             
        On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein 
          
        For Each FileItem In SourceFolder.Files 
            If LCase(FileItem.Name) Like LCase(DateiFormat) Then 
             Redim Preserve FileArray(LCount) 
             FileArray(LCount) = FileItem 
             LCount = LCount + 1 
            End If 
        Next FileItem 
     
     
        If IncludeSubfolders Then 
            For Each SubFolder In SourceFolder.SubFolders 
                ListFilesInFolder FileArray, SubFolder.Path, DateiFormat, IncludeSubfolders, LCount 
            Next SubFolder 
        End If 
 Else 
       MsgBox "Ordner nicht gefunden!", vbCritical 
 End If 
 
Err_Zugriff: 
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing 
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread