127946
Goto Top

Excel - Daten aus ungeöffneten Excel-Dateien auslesen

Hallo,

ich bin neu hier und kämpfe mit einem kleinen Problem bei deinem ich eure Hilfe brauch.

In einem Ordner liegen meherere Excel-Dateien.
Diese enthalten alle jeweils ein gleichnamiges Tabellenblatt mit Namen "übersicht".
Davon soll jeweils der Bereich A2:A46 ausgelesen werden.

In der Zieldatei soll diese Bereiche dann nebeneinander darstellt werden
Also so:

Datei1A2 ; Datei2A2 ; Datei3A5 ...
Datei1A3 ; Datei2A3 ; Datei3A5 ...
Datei1A4 ; Datei2A4 ; Datei3A5 ...
...

Die Anzahl der Dateien im Ordner ist nicht konstant.
Die Dateien sind bis auf die Zieldatei alle ungeöffnet.

Ich wäre um jede Hilfe dankbar. face-smile
Ich bastel an der Aufgabe nun schon eine Weile rum, aber bin leider noch nicht auf den grünen Zweig gekommen.

Liebe Grüße & vielen Dank für jeden Rat,
Aldior

Content-Key: 299090

Url: https://administrator.de/contentid/299090

Ausgedruckt am: 28.03.2024 um 19:03 Uhr

Mitglied: 126919
126919 14.03.2016 um 10:51:26 Uhr
Goto Top
Mitglied: MrCount
Lösung MrCount 14.03.2016 aktualisiert um 11:23:13 Uhr
Goto Top
Hallo Aldior,

ich habe etwas ähnliches schon mal gebaut.

Dieses Script liest die Dateien (*.xls) in einem Ordner so ein, dass Werte bestimmter Zellen in ein Array kopiert werden, welche dann im Tabellenblatt "gesammelt" werden.

Vielleicht kannst du den Code ja mit ein paar Anpassungen verwenden...

Sub Schaltfläche1_Klicken()

Dim dat
Dim ordner
Dim datein
Dim fso
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Ein Array mit 500 Zeilen und 6 Spalten.  
'Dient zur späteren Aufnahme der Werte.  
Dim arr(500, 6)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXX  
Dim L As Long
Dim Z As Long
Dim WB
Dim dsplalert As Boolean
Dim cal
Dim scrup As Boolean
Dim ev As Boolean
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Zum Beschleunigen des Makros  
With Application
    dsplalert = .DisplayAlerts
    cal = .Calculation
    scrup = .ScreenUpdating
    ev = .EnableEvents
    .DisplayAlerts = False              'Excelinterne Meldungen aus  
    .Calculation = xlCalculationManual  'Automatische Berechnung aus  
    .ScreenUpdating = False             'Bildschirm aktualisierung aus  
    .EnableEvents = False               'Makrostarts aus  
End With

'XXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Überschriften ins Array schreiben  
arr(L, 0) = "Datum"  
arr(L, 1) = "Rechnungsnummer"  
arr(L, 2) = "Kundennummer"  
arr(L, 3) = "Kundenname"  
arr(L, 4) = "MwSt"  
arr(L, 5) = "Gesamtbetrag"  
L = L + 1
'XXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Dialog aufrufen  
'Die innere IF-Then Konstruktion fängt "Abbrechen" in dem Dialog ab.  
Set dat = Application.FileDialog(msoFileDialogFolderPicker)
With dat
   .Title = "Suchen..."  
   .InitialFileName = "C:\" 'oder was auch immer  
nochmal:
If .Show = -1 Then
    ordner = .SelectedItems(1)
Else:
    If MsgBox("Ordner auswählen vergessen." & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then  
    GoTo nochmal
    Else:
        GoTo raus
    End If
End If
End With
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Zugriff aus Dateisystem  
Set fso = CreateObject("Scripting.filesystemobject")  
Set datein = fso.getfolder(ordner)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Sucht jedes file in Ordner.  
'i istdie Variable  
For Each WB In datein.Files
    If WB.Name Like "*.xlsx" Or WB.Name Like "*.xls" Then 'selbserklärend  
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXX  
        Workbooks.Open WB        'selbserklärend  
                arr(L, 0) = Sheets(1).Cells(16, 6).Text
                arr(L, 1) = Sheets(1).Cells(17, 2).Text
                arr(L, 2) = Sheets(1).Cells(18, 1).Text
                arr(L, 3) = Sheets(1).Cells(9, 1).Text
                arr(L, 4) = Sheets(1).Cells(31, 4).Text
                arr(L, 5) = Sheets(1).Cells(33, 6).Text
                L = L + 1
                
        Workbooks(WB.Name).Close False
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXX  
    End If
Next
Range("A:F") = arr 'Alle Werte auf einmal in die Tabelle übertragen  

raus:
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX  
'Die Eingangs gemachten Einstellungen Rückgängig machen  
With Application
     .DisplayAlerts = dsplalert
     .Calculation = cal
     .ScreenUpdating = scrup
     .EnableEvents = ev
End With
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX  

End Sub

Gruß
Mitglied: 127946
127946 14.03.2016 um 19:27:23 Uhr
Goto Top
Vielen Dank!!
Dieser Beitrag hat mich auf den richtigen Trichter gebracht.
An die Lösung über Array hatte ich nicht gedacht face-smile

LG,
Mitglied: MrCount
MrCount 15.03.2016 um 08:02:12 Uhr
Goto Top
Gern geschehen! face-big-smile