Daten aus geschlossenen Datein übertragen
26.02.2019 18:22:29
Sebastian
ich habe über recherchen den nachstehenden Code von Herrn Wershoven gefunden, der grundsätzlich das macht was ich brauche. Allerdings läuft der Code durch ohne Fehlermeldung und ohne das er irgendwas kopiert. In Zelle A1 bis BA32 sind auch durchgehend werde vorhanden, ohne leerzeilen. Könnte mir hier jemand helfen woran das liegen könnte? Alternativ wäre es vielleicht einfacher möglich (und flexibler) einen festen Bereich zu kopieren statt alle genutzten Zellen zu kopieren?
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_datensammeln5.php
' ************************************************************************************************
Sub MWTabellenAusMehrerenDateienEinlesen()
Dim oTargetSheet1 As Object
Dim oSourceBook1 As Object
Dim sPfad As String
Dim sDatei As String
Dim lErgebnisZeile As Long
Dim s As Long
Dim z As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
'****1. Kopieren Berichte aktuelles Jahr****
'Schritt 1: Arbeitsblatt für die Ergebnisse festlegen
Set oTargetSheet1 = ActiveWorkbook.Sheets("Bericht")
lErgebnisZeile = 2 'Ergebnisse eintragen ab Zeile 2
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "\\bla\blub\XXX\XXX\XXX\XXX\XXX\2019"
sDatei = Dir(CStr(sPfad & "*2019_Bericht.xlsx*")) 'Alle Excel Dateien
Do While sDatei ""
'Schritt 3: öffnen der Datei und Datenübertragung
Set oSourceBook1 = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
'Datenübertragung alle genutzten Zeilen und Spalten
For z = 1 To oSourceBook1.Sheets("Summe").UsedRange.Rows.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSourceBook1.Sheets("Summe").Cells(z, 1).Value)) "" Then
For s = 1 To oSourceBook1.Sheets("Summe").UsedRange.Columns.Count
'Spalte 1 - Dateinamen
oTargetSheet1.Cells(lErgebnisZeile, 1).Value = sDatei
'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1"
oTargetSheet1.Cells(lErgebnisZeile, s + 2).Value = _
oSourceBook1.Sheets("Summe").Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1
End If
Next z
'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
oSourceBook1.Close False 'nicht speichern
'Nächste Datei
sDatei = Dir()
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet1 = Nothing
Set oSourceBook1 = Nothing
MsgBox "Aktualisierung abgeschlossen", vbApplicationModal
End Sub
Gruß Sebastian