Zellen auslesen! Programm überfordert

Bild

Betrifft: Zellen auslesen! Programm überfordert
von: baschti007
Geschrieben am: 08.10.2015 14:21:41

Hallo Ich habe mir ohne Vba Kenntnisse ein kleines Programm gebaut was zu auslesen von xls und xlsx Dateien ist . Nur leider liegen in dem Ordner mehr als 2000 Dateien und das Programm ließt nur ca. 1000 aus und verbraucht dann ca.350MB Ram ich denke das es auch anders gehen müsste aber ich weis nicht wie.
Ich hatte schon eine andere Methode nur leider musste man jede Dateien bestätigen welches Tabellenblatt er auslesen soll.
Hoffe Ihre könnt mir weiter helfen.
Option Explicit
Const sXlsPath = "pfad"
Const iStartZeile = 3
Const iStartSpalte = 2
Const Zellen = "B22,O23,O21,O19,O25,O27,O33,D39,E39,F39,G39,H39,I39,J39,K39,L39,M40,D40,E40,F40, _
G40,H40,I40,J40,K40,L40,M40,D42,E42,F42,G42,H42,I42,J42,K42,L42,M42,D43,E43,F43,G43,H43,I43,J43, _
K43,L43,M43,D44,E44,F44,G44,H44,I44,J44,K44,L44,M44,D4,C69,D5,D17,K9,D37,K13"


Sub Test()
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As  _
Worksheet
    Dim aCells As Variant, iNextLine As Long, i As Integer
    
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Dim Pfad As String, Strmappe As String
    Dim strName As String
    Dim strStartPath As String
    
    
    Dim FSO As Object
    Dim strPfad As String
    Dim x As Integer
    Dim strGef As Object
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    With ActiveSheet
        Range("E1:G1").Select
        Selection.ClearContents
        Range("Tabelle13").Select
        Selection.AutoFilter
        Range("Tabelle13").Select
        Selection.Clear
    End With
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    strStartPath = "17" ' "U:\Prüfprotokolle\" '<-- Startordner "17" ist Alle Ordner
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H10000, (strStartPath))
    On Error Resume Next
    Pfad = BrowseDir.items().Item().Path
    If Pfad = "" Then Selection.AutoFilter
    If Pfad = "" Then Exit Sub
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    
    Range("E1") = Pfad
      Application.ScreenUpdating = False
    
    
    
    
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   Set oWks0 = ThisWorkbook.ActiveSheet
   aCells = Split(Zellen, ","):  iNextLine = iStartZeile
   Set oFso = CreateObject("Scripting.FilesystemObject")
   For Each oFile In oFso.GetFolder(Pfad).Files
        If LCase(oFso.GetExtensionName(oFile.Name)) = "xls" Or "xlsx" Then
            If ThisWorkbook.Name <> oFile.Name Then
                Set oWkb1 = Workbooks.Open(oFile.Path)
                Set oWks1 = oWkb1.Sheets(1)
                For i = 0 To UBound(aCells)
                    oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells( _
i))).Value
                Next
                oWkb1.Close False
                iNextLine = iNextLine + 1
            End If
        End If
    Next
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
     
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  
        Set FSO = CreateObject("Scripting.FilesystemObject")
    For Each strGef In FSO.GetFolder(Pfad).Files
    Select Case LCase(FSO.GetExtensionName(strGef))
    Case "xls", "xlsx"
    x = x + 1
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(x + 2, 1), Address:= _
    strGef, TextToDisplay:=strGef.Name
  End Select
Next
    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
ActiveSheet.ListObjects("Tabelle13").Range.AutoFilter Field:=60, Criteria1:= _
        "OK"
        
        With Selection
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlBottom
       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
       End With
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Application.ScreenUpdating = True
End Sub

Vielen Dank

Bild

Betrifft: AW: Zellen auslesen! Programm überfordert
von: Hajo_Zi
Geschrieben am: 10.10.2015 12:09:50
die Aktionen die gemacht werden sollen hast Du ja schon. Zum Ordner auslesen
http://hajo-excel.de/chCounter3/getfile.php?id=21


Bild

Betrifft: AW: Zellen auslesen! Programm überfordert
von: baschti007
Geschrieben am: 14.10.2015 06:53:38
Ja Danke aber das habe ich ja schon mit den Ordnern auslesen es geht mit eher darum das man dieses ausliest ohne die Dateien zu öffnen und ohne zu bestätigen welches Tabellen Blatt er auslesen soll aber wie es aussieht ist so etwas nicht umzusetzen .
Danke Gruß Basti

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Zellen auslesen! Programm überfordert"