AW: Auflistungen
19.11.2003 10:19:47
Nike
Moin,
also, verdeutscht würd ich sagen, du legst ein neue Code Modul
in deiner Datei im VBA Editor an und kopierst dann den folgenden Code:
Sub Auswert()
Dim arrFilenames As Variant
Dim wkbArr As Workbook
Dim wkbBasis As Workbook
Dim wksBasis As Worksheet
Dim wksArr As Worksheet
Dim lngZeil As Long
Dim lngZZeil As Long
Dim lngLZeil As Long
Dim strAuftragNr As String
strAuftragNr = Application.InputBox("Bitte die Auftragsnummer eingeben, nach der gesucht werden soll", "Auftragsnummer")
If strAuftragNr = "" Or strAuftragNr = "Falsch" Then Exit Sub
Set wkbBasis = ActiveWorkbook
Set wksBasis = wkbBasis.Worksheets.Add
Selection:
' Zu öffnende Dateien erfragen
arrFilenames = Application.GetOpenFilename( _
"Exceldateien (*.xls), *.xls, Alle Dateien (*.*), *.*", 1, _
"Exceldateien auswählen...", MultiSelect:=True) ' Ausgewählte Dateien des Öffnen-Dialoges in Feld ablegen
If VarType(arrFilenames) = vbBoolean Then
If MsgBox("Sie haben keine Dateien ausgewählt. Möchten sie das Makro beenden?", vbYesNo, "Frage") = vbNo Then
GoTo Selection
Else
Set wbkBasis = Nothing
Exit Sub
End If
End If
Application.ScreenUpdating = False
'Die vom Makro vorgenommenen Tätigkeiten
'bleiben zur Geschwidigkeitssteigerung unsichtbar
lngZZeil = 1
For i = 1 To UBound(arrFilenames) ' Durchläuft die Anzahl der Dateien
'Wenn Datei noch nicht geöffnet
If FileOpenYet(Dir$(arrFilenames(i))) = False Then
'dann öffnen
Workbooks.Open FileName:=arrFilenames(i)
Else
'oder aktivieren
Workbooks(Dir$(arrFilenames(i))).Activate
End If
Set wkbArr = ActiveWorkbook
'hier kommt dann der Code rein, der die ausgewählten Dateien
'betrifft. Die Ursprungsdatei ist über wbkBasis ansprechbar.
lngZeil = 4
If Right(wkbArr.Worksheets(1).Name, 11) = "Zeiten 2003" Then
Set wksArr = wkbArr.Worksheets(1)
ElseIf Right(wkbArr.Worksheets(2).Name, 11) = "Zeiten 2003" Then
Set wksArr = wkbArr.Worksheets(2)
Else
Exit Sub
End If
lngLZeil = wksArr.Cells(wksArr.Rows.Count, 5).End(xlUp).Row
datTag = CDate(wksArr.Cells(lngZeil, 3))
Do
lngZeil = lngZeil + 1
lngStep = lngStep + 1
If lngStep = 10 Then
datTag = DateSerial(wksArr.Cells(lngZeil, 2), Month(wksArr.Cells(lngZeil, 4)), Day(wksArr.Cells(lngZeil, 4)))
lngStep = 0
End If
If wksArr.Cells(lngZeil, 5) = strAuftragNr Then
wksBasis.Cells(lngZZeil, 1).Value = Left(wksArr.Name, InStr(1, wksArr.Name, " ") - 1)
wksBasis.Cells(lngZZeil, 2).Value = strAuftragNr
wksBasis.Cells(lngZZeil, 3).Value = datTag
wksArr.Range(wksArr.Cells(lngZeil, 7), wksArr.Cells(lngZeil, 12)).Copy _
wksBasis.Range(wksBasis.Cells(lngZZeil, 7), wksBasis.Cells(lngZZeil, 12))
lngZZeil = lngZZeil + 1
End If
Loop Until lngZeil = lngLZeil
wkbArr.Close SaveChanges:=False 'Datei schließen
Set wkbArr = Nothing
Next i
Set wkbArr = Nothing
'Ursprüngliche Datei wieder aktivieren
wkbBasis.Activate
Set wkbBasis = Nothing 'Die Variable zurücksetzen
'und den Monitor aktivieren
Application.ScreenUpdating = True
End Sub
Function FileOpenYet(FileName As String) As Boolean
'eine Funktion, die Prüft ob eine Datei schon geöffnet ist.
Dim s As String
On Error GoTo Nonexistent
s = Workbooks(FileName).Name
FileOpenYet = True
Exit Function
Nonexistent:
FileOpenYet = False
End Function
Anschließend speicherst du die Datei
und rufst dann die Prozedur Auswerten
mittels der Tastenkombination Alt F8 auf.
Anschließend wählst du deine Mitarbeiterdateien aus.
Es sollte dann ein neues Blatt angelegt werden,
in dem dann die Werte stehen...
Bye
Nike