Sub Uebernahme_Jani()
'Es sollen von ca. 1.500 Dateien die Werte des Bereichs A4:I23 in eine Datei (Vorlage.xls)
'untereinander kopiert werden. Wird sehr lange dauernDim I As Integer, IRow As Integer 'Counter
Dim Pfad As String, DATmPF As String 'Pfad
Dim DAT As String, DAT1 As String 'Dateinamen
Dim Zelle As String '
Dim Anz As Integer 'Anzahl der Dateien
Dim Zahl As Byte
On Error GoTo ErrorHandler
Application.ScreenUpdating = False 'Schaltet Bildschirmupdate ab
Application.DisplayAlerts = False 'Schaltet die Warnmeldungen aus
IRow = 4
Pfadangabe:
Pfad = InputBox("Bitte den Pfad mit Laufwerksbuchstaben angeben: ", "Pfad")
If Mid(Pfad, 2, 2) <> ":\" Then
MsgBox ("Haben Sie vielleicht den Laufwerksbuchstaben vergessen ?")
GoTo Pfadangabe
End If
Anzahldateien:
Anz = InputBox("Bitte geben Sie die Anzahl der Dateien ein," & Chr(10) & _
"die verarbeitet werden sollen", "Anzahl Dateien")
If Anz > 100 Then
MsgBox ("Das könnte ziemlich lange dauern bei über 100 Dateien !!!")
End If
Dateiangabe:
DAT = InputBox("Bitte geben Sie den 1. Dateinamen ein: ", "Dateiname")
If Right(DAT, 4) = ".xls" Then
DAT = Left(DAT, Len(DAT) - 4)
End If
On Error GoTo ErrorEndung
Zahl = Right(DAT, 3) * 1
I = Right(DAT, 3)
DAT = Left(DAT, Len(DAT) - 3)
Range("B4").Select
For I = 1 To Anz
On Error GoTo ErrorHandler
DATmPF = Pfad & "\" & DAT & Format(I, "#000") & ".xls"
Zelle = Cells(IRow, 2).Address
Range(Zelle).Select
'Arbeitsmappe öffnen
ChDir Pfad
Workbooks.Open Filename:=DATmPF
Range("B4:I23").Select
Selection.Copy
Workbooks("vorlage.xls").Worksheets("Tabelle1").Activate
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Arbeitsmappe schließen
DAT1 = DAT & Format(I, "#000") & ".xls"
Workbooks(DAT1).Close saveChanges = False
IRow = IRow + 20
Next
Application.ScreenUpdating = True 'Schaltet Bildschirmupdate ab
Application.DisplayAlerts = True 'Schaltet die Warnmeldungen wieder ein
Exit Sub
ErrorEndung:
MsgBox ("sollten die letzten 3 Zeichen nicht Zahlen sein ?")
GoTo Dateiangabe
ErrorHandler:
MsgBox ("Es ist ein Fehler aufgetreten." & Chr(10) & _
Chr(10) & "mögliche Fehler konnen sein:" & Chr(10) & _
"1.) Es sind weniger Dateien vorhanden als bei Anzahl angegeben" & Chr(10) & _
"2.) Die Dateien sind nicht fortlaufend, bzw. vielleicht fehlen welche" & Chr(10) & _
Chr(10) & "Das Programm wird nun beendet !!!")
End Sub