Inhalte von mehreren Arbeitsblätter in einem Arbeitsblatt untereinander kopieren

Hallo Liebe Leute,

ich habe mich zwar im Forum detailliert umgesehen und Lösungsvorschläge anderer Beiträge versucht anzuwenden, leider jedoch gescheitert.

Ich habe eine Exceldatei in dem die tägliche Kassa gehalten wurde und für jeden Tag ein Arbeitsblatt erstellt. Die Arbeitsblätter sind mit dem Datum des jeweiligen Tages umbenannt (01.01.2013, 02.01.2013, etc.). Eingänge und Ausgänge wurden hiermit festgehalten aber die Erklärungen sind immer unterschiedlich gehalten worden, d.h. keine einheitliche Struktur (z.B. Saphire Gehaltszahlung, Saphire Lohn, Saphire Zahlung für Dezember) wobei nicht einmal der Bezug Saphire immer gleich geschrieben wurde aufgrund Tippfehler.

Nun muss ich diese Dateien überprüfen und zu einem übersichtlichen Schema umwandeln.

Ich habe als erstes versucht die Inhalte dieser Arbeitsblätter in einem Arbeitsblatt zusammenzufassen um mit dem Autofilter die Daten zu filtern und habe mir im Forum dieses VBA herangezogen.


Option Explicit

Sub Sammle()
Const sSourcePath As String = "D:\KASA2015Z.xlsx\"
Dim wbGes As Workbook, wsTarget As Worksheet
Dim wbTeil As Workbook, wsSource As Worksheet
Dim fso As Object, oFile As Object
Dim rNext As Integer, bSheetFound As Boolean
Set wbGes = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")

'Quell-Ordner durchsuchen
For Each oFile In fso.GetFolder(sSourcePath).Files
'nur .xls-Dateien bearbeiten
If LCase(Right(oFile.Name, 4)) = ".xls" Then
Application.Workbooks.Open (oFile.Path)
Set wbTeil = ActiveWorkbook
'alle Tabellen der Gesamt-Datei bearbeiten
For Each wsTarget In wbGes.Worksheets
'Tabelle auch in Teil-Datei enthalten?
For Each wsSource In wbTeil.Worksheets
bSheetFound = False
If LCase(wsTarget.Name) = LCase(wsSource.Name) Then
bSheetFound = True
Exit For
End If
Next
If bSheetFound Then
'Tabelle da, Daten kopieren ...
wbTeil.Worksheets(wsTarget.Name).Activate
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Copy
'... und einfügen in Gesamt-Datei-Tabelle...
wbGes.Worksheets(wsTarget.Name).Activate
'... ab der nächsten freien Zeile
rNext = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
ActiveSheet.Cells(rNext, 1).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
End If
Next 'Tabelle
wbTeil.Close
End If
Next 'Datei
wbGes.Worksheets(1).Activate
'Gesamt-Datei speichern
wbGes.Save
MsgBox "Fertig."
End Sub


Laufzeitfehler 76 war dann das Ergebnis.

Weiters habe ich versucht die Inhalte aufgrund eines Suchbegriffs zu extrahieren, mittels dieser VBA aber auch ohne Erfolg.

Bitte um eure Lösungsvorschläge und Danke schon im Voraus.

Quelltext | Drucken
01.
Option Explicit
02.

03.
Sub GetData()
04.

05.
Dim oMe As Object
06.
Set oMe = Workbooks("Alle.xls").Worksheets("Tabelle1") 'ZielDatei/-Tabelle (also die gerade geöffnete)
07.
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende
08.
Const iSbAnzahl = 3 'Nach 3 Begriffen suchen
09.
Dim sSuchbegriff(iSbAnzahl) As String
10.
sSuchbegriff(1) = "Name"
11.
sSuchbegriff(2) = "Vorname"
12.
sSuchbegriff(3) = "Strasse"
13.

14.
Dim i As Integer
15.
Dim sWbName As String
16.
Dim rFound As Range
17.
Dim vWert As Variant
18.
Dim iZeile As Integer
19.

20.
iZeile = 2
21.
Dim oFS As Object, oDatei As Object
22.
Set oFS = CreateObject("Scripting.FileSystemObject")
23.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
24.
sWbName = oDatei.Name
25.
Workbooks.Open (sDateiPfad & sWbName)
26.
For i = 1 To iSbAnzahl
27.
Set rFound = Workbooks(sWbName).Worksheets(1).Range("a1:a100").Find(sSuchbegriff(i), LookIn:=xlValues)
28.
If Not rFound Is Nothing Then
29.
vWert = Cells(rFound.Row, rFound.Column + 1).Value
30.
oMe.Cells(iZeile, i).Value = vWert
31.
End If
32.
Next
33.
Workbooks(sWbName).Saved = True
34.
Workbooks(sWbName).Close
35.
iZeile = iZeile + 1
36.
Next
37.
End Sub