Hallo Andreas,
hier schon mal ein Lösungsvorschlag, der dann funktioniert, wenn die Informationen in den Rechnungsdateien immer in dengleichen Zellen stehen.
Falls das nicht der Fall ist, dann muß man sich überlegen, wie man die Informationen in der Rechnungsdatei finden kann und die Case-Anweisungen für die einzelnen Felder anpassen.
Hier das Makro, ein Beispiel für die Kunden-Datei, und ein Beispiel für die verwendete Rechnungsdatei. Das Makro wird in der Kunden-Datei gespeichert. Die Kunden-Datei darf nicht in dem Verzeichnis gespeichert werden, in dem sich die Rechnungs-Dateien befinden.
Sub RechnungenAuslesen()
'Auslesen der Kundendaten aus Rechnungsdateien
Dim Datensatz As Range
Application.ScreenUpdating = False
Datei = ActiveWorkbook.Name
Tabelle = ActiveWorkbook.ActiveSheet.Name
Felder = 8 'Zahl der Felder, die ausgelesen werden sollen
InputTitel = "Kundendaten aus Rechnungen auslesen"
MsgText = "Ist die Aktive Zelle in der Zeile ab der die Daten Eingefügt werden sollen?"
MsgText = MsgText & Chr$(10) & "Falls 'NEIN', dann bitte erst Zelle markieren!"
If MsgBox(MsgText, vbYesNo, InputTitel) = vbNo Then Exit Sub
Zeile = ActiveCell.Row 'Zeile ab der die nächsten Einträge beginnen
InputPrompt = "Suchschema, das bei der Auswahl der Rechnungen verwendet werden soll?"
InputVorgabe = "\*.XLS"
Schema = InputBox(InputPrompt, InputTitel, InputVorgabe)
If Schema = "" Then GoTo Abbruch
' Im nachfolgend angezeigten Dialog muß eine Datei in dem Verzeichnis geöffnet werden
' in dem sich die Dateien befinden, deren Daten geändert werden sollen.
Test = Application.Dialogs.Item(xlDialogOpen).Show
Pfad = ActiveWorkbook.Path
If Test = Falsch Then GoTo Abbruch 'Es wurde keine Datei ausgewählt
ActiveWorkbook.Close SaveChanges:=False
Rechnung = Dir(Pfad & "\" & Schema) ' Erste Rechnung öffnen.
Do While Rechnung "" ' Schleife beginnen.
Set Datensatz = Application.Range(Cells(Zeile, 1), Cells(Zeile, Felder))
On Error GoTo FehlerOeffnen
Application.Workbooks.Open Rechnung
' Auslesen und Eintragen der Zellenfelder
For X = 1 To Felder
Select Case X
Case 1 'Kundennummer
Datensatz(1, X) = Cells(1, 3)
Case 2 'Name
Datensatz(1, X) = Cells(4, 1)
Case 3 'Name Zusatz
Datensatz(1, X) = Cells(5, 1)
Case 4 'Adresse Zusatz
Datensatz(1, X) = Cells(6, 1)
Case 5 'Adresse Strasse
Datensatz(1, X) = Cells(7, 1)
Case 6 'Adresse PLZ
Datensatz(1, X) = Cells(8, 1)
Case 7 'Adresse Ort
Datensatz(1, X) = Cells(8, 2)
Case 8 'Datum Rechnung
Datensatz(1, X) = Cells(1, 7)
End Select
Next
'Datei Schließen
ActiveWorkbook.Close SaveChanges:=False
'Fortschritt beim Einlesen anzeigen
Application.ScreenUpdating = True
ActiveCell.Offset(1, 0).Select
Application.ScreenUpdating = False
I = I + 1
If I = 25 Then 'Alle 25 Einträge wird die neue Kundenliste gesichert.
ActiveWorkbook.Save
I = 0
End If
GoTo NaechsteRechnung
FehlerOeffnen:
MsgText = "Beim Öffnen der Datei " & Rechnung & " ist ein Fehler aufgetreten."
MsgText = MsgText & Chr$(19) & "Nächste Datei öffnen?"
If MsgBox(MsgText, vbYesNo, InputTitel) = vbNo Then Exit Sub
NaechsteRechnung:
Zeile = Zeile + 1
Rechnung = Dir ' Nächstes Dokument abrufen.
Loop
Application.ScreenUpdating = True
MsgBox ("Die Rechnungen im gewählten Verzeichnis wurden ausgelesen!")
Exit Sub
Abbruch:
MsgBox ("Die Ausführung des Nakros wurde abgebrochen!")
End Sub
Tabellenblattname: Kundenliste
A B C D E F G H
1 KundenNr Name NameZusatz AdrZusatz Straße PLZ Ort Datum
2 A23455333 Fa ADE Herr Meier OT Oberer Bergstrasse 32 01234 Testdorf 01.01.04
3 A23455300 Fa XYZ Herr Schulze Teststrasse 32 D-21234 Testdorf 2 02.01.04
4 B23455400 Fa ABC Frau Frieder Testweg 99 D-99999 Teststadt 02.01.05
Tabellenblattname: Rechnung
A B C D E F G
1 Kunden-Nr. A23455333 Datum 01.01.2004
2
3
4 Fa ADE
5 Herr Meier
6 OT Oberer
7 Bergstrasse 32
8 01234 Testdorf
Gruß
Franz
[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]