Severus schrieb am 10.11.2010 06:53:47:
Als erstes in der Entwicklungsumgebung im Menü "Extras->Verweise"
einen Verweis auf die "Microsoft Scripting Runtime" setzen.
Code:
Sub Eintragen()
Dim FSO As New Scripting.FileSystemObject
Dim Ordner As Scripting.Folder
Dim DateiListe As Scripting.Files
Dim Datei As Scripting.File
Dim strDatei As String
Dim SpaltenVerschub As Long
Dim ZeilenVerschub As Long
With ThisWorkbook
With ActiveSheet
.Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, 6)).Select
Selection.Clear
.Range("A2").Select
ZeilenVerschub = -1
Set Ordner = FSO.GetFolder("C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig")
If Ordner Is Nothing Then Exit Sub
Set DateiListe = Ordner.Files
If DateiListe Is Nothing Then Exit Sub
For Each Datei In DateiListe
SpaltenVerschub = 0
strDatei = Datei.Name
If InStr(1, UCase(Right(Datei.Name, 4)), "XLS", vbBinaryCompare) <> 0 Then
'Nächste Zeile
ZeilenVerschub = ZeilenVerschub + 1
'Spalte A
ActiveCell.Offset(ZeilenVerschub, SpaltenVerschub).Formula = "='C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig\[" & strDatei & "]Kunden'!$A$2"
SpaltenVerschub = SpaltenVerschub + 1
'Spalte B
ActiveCell.Offset(ZeilenVerschub, SpaltenVerschub).Formula = "='C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig\[" & strDatei & "]Kunden'!$B$2"
SpaltenVerschub = SpaltenVerschub + 1
'Spalte C
ActiveCell.Offset(ZeilenVerschub, SpaltenVerschub).Formula = "='C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig\[" & strDatei & "]Kunden'!$A$4"
SpaltenVerschub = SpaltenVerschub + 2
'Spalte E
ActiveCell.Offset(ZeilenVerschub, SpaltenVerschub).Formula = "='C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig\[" & strDatei & "]Kunden'!$AH$1"
SpaltenVerschub = SpaltenVerschub + 1
'Spalte F
ActiveCell.Offset(ZeilenVerschub, SpaltenVerschub).Formula = "='C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig\[" & strDatei & "]Kunden'!$AI$1"
End If
Next
End With
End With
Set DateiListe = Nothing
Set Ordner = Nothing
End Sub
Der Code löscht immer die alten Einträge, bevor er neue Schreibt, damit nicht die Dateien doppelt drinstehen.
Wichtig: Hier ist vorausgesetzt, daß alle Dateien ein Arbeitsblatt "Kunden" haben, da hier ja keine manuelle Eingabe erfolgt und das Programm nicht nach anderen Arbeitsblättern sucht. Allerdings bietet Excel/VBA im Falle, daß "Kunden" fehlt, die vorhandenen Arbeitsblätter zur Auswahl in einem Dialog an.
Severus
Hallo Severus,
dass klappt soweit schon super, er trägt alle Daten auch ein, allerdings erhalte ich den Fehler: "Laufzeitfehler '1004': Anwendungs- oder objektdefinierter Fehler" und bei wiederholtem ausführen des Codes wird in der ersten Zeile alles aus A bis F gelöscht.
Beim Debuggen wird:
ActiveCell.Offset(ZeilenVerschub, SpaltenVerschub).Formula = "='C:\Dokumente und Einstellungen\Administrator\Desktop\Fertig\[" & strDatei & "]Kunden'!$A$2" markiert.
vielen Dank schon einmal.
Grüße,
Niklas |