Laufzeitfehler beim Zusammenführen von Daten

Sub Zusammenfassen() squellpfad = "C:\Ringversuchsauswertungen" Q = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", " _ _ _ R", "S") 'Quellzellen Z = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", " _ _ _ R", "S") ' Zielspalten in Sammeldatei R = 3 'Startzeile in Sammeltabelle Set wbGes = ActiveWorkbook Set fso = CreateObject("Scripting.Filesystemobject") N = UBound(Q) For Each oFile In fso.Getfolder(squellpfad).Files If LCase(Right(oFile.Name, 4)) = ".xls" Then Application.Workbooks.Open oFile.Path For i = 0 To N wbGes.Worksheets(1).Cells(R,Z(S)).Value=ActiveWorkbook.Worksheets(1).Range(Q(S)) _ _ Value Next ActiveWorkbook.Close False R = R + 1 End If Next wbGes.Save MsgBox "Fertig." End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
hast Du den Code nicht selbst geschrieben?
Versuch es mal so!

Sub Zusammenfassen()
Dim ArFiles()
Dim Q, Z
Dim R&, n&, nn&
Dim sQuellPfad$, sDir$
Dim wbGes As Workbook, wbQuelle As Workbook
sQuellPfad = "C:\Ringversuchsauswertungen\"
'Dateien Suchen
ChDrive sQuellPfad
ChDir sQuellPfad
sDir = Dir(sQuellPfad & "*.xls", vbNormal)
Do While sDir  ""
ReDim Preserve ArFiles(n)
ArFiles(n) = sQuellPfad & sDir
n = n + 1
sDir = Dir$()
Loop
'alte Daten löschen
Set wbGes = ActiveWorkbook
With wbGes.Worksheets(1)
If .UsedRange.Cells(.UsedRange.Rows.Count, 1).Row > 2 Then
.Range(.Cells(3, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
End If
End With
'Datei gefunden?
If n > 0 Then
'Bremsen im Excel deaktivieren
Events_ False
'Quelle und Ziel.
Q = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", " _
Q", "R", "S") 'Quellzellen
Z = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", " _
Q", "R", "S") ' Zielspalten in Sammeldatei
'Startzeile in Sammeltabelle
R = 3
For n = LBound(ArFiles) To UBound(ArFiles)
'Datei öffnen
Set wbQuelle = Workbooks.Open(ArFiles(n), ReadOnly:=True)
'Datei Tabelle mit Index1
With wbQuelle.Worksheets(1)
'Schleife über Spalten im Array Q
For nn = LBound(Q) To UBound(Q)
With .Range(Q(nn) & 1, .Range(Q(nn) & .Rows.Count).End(xlUp))
wbGes.Worksheets(1).Range(Z(nn) & R).Resize(.Rows.Count).Value = .Value
End With
Next nn
End With
'schließen ohne speichern
wbQuelle.Close False
'nächste freie Zeile
With wbGes.Worksheets(1).UsedRange
R = .Cells(.Rows.Count, 1).Row + 1
If R

Gruß Tino

Hallo Tino,
es ist so:
Aus deiner Tabelle nimmt er alles so wie es soll, aus meiner Tabelle nicht, warschienlichen ein Formatierungsfehler meinerseits in den Tabellen.
Das einzige was ich immernoch nicht verstehe ist, warum er nicht den Speicherpfad übernimmt wo er suchen soll. Auf meinem rechner ging alles Wunderbar. Ich habe dann den Testordner verschoben und im Code angebpasst. Er sucht aber weiterhin in anderen Ordnern. Das heißt: Ich habe den Ordner ins Laufwwerk F verschoben. Er sucht sich dann abernurnoch deine Testdateien aus dem Ordner, die aber garnicht mehr vorhanden sind. Meine Dateien die Im Ordner sind interessieren dann nicht mehr.Und wenn ich den Pfad wieder ändere, bleibt es gleich und ers icht sich wieder nur deine Dateien Raus. MAche ich vielleicht was falsch?
Patrick

Beliebteste Forumthreads (12 Monate)

Laufzeitfehler beim Zusammenführen von Daten

27 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

27
Beiträge zum Forumthread

Beiträge zu diesem Forumthread