' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub zusammenfassung()
Dim vntAuflauf As Variant, vntOut() As Variant
Dim objSh As Worksheet, vntRet As Variant, rng As Range
Dim lngI As Long, lngAnswer As Long, lngR As Long, lngC As Long, lngInsert As Long
Dim strFirst As String
Const cSheetName As String = "Zusammenfassung"
Const cLngSearchColumn As Long = 4 'Spalte in "Bestellungen" die durchsucht wird - Anpassen!
Const cLngCriteriaColumn As Long = 2 'Spalte in der die Nummern in "Auflauf" stehen - Anpassen!
Const cLngLastColumn As Long = 3 'Spalte bis zu der die Daten aus "Bestellungen" übertragen werden sollen - Anpassen!
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
If Not SheetExist(cSheetName) Then
Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
objSh.Name = cSheetName
Else
lngAnswer = MsgBox("Ausgabe auf Tabelle '" & cSheetName & "'" & vbTab & "= [JA]" & vbLf & _
"Ausgabe auf neuem Tabellenblatt" & vbTab & "= [NEIN]", vbQuestion + vbYesNo)
If lngAnswer = 7 Then
Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
objSh.Name = cSheetName & Format(Now, "_ddmmyy_hhmmss")
ElseIf lngAnswer = 6 Then
Set objSh = Sheets(cSheetName)
objSh.UsedRange.Clear
Else
Exit Sub
End If
End If
With Sheets("Auflauf")
vntAuflauf = .Range("A2:H" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
.Rows(1).Copy objSh.Range("A1")
End With
lngInsert = 2
With Sheets("Bestellungen")
For lngI = 1 To UBound(vntAuflauf, 1)
lngR = 1
strFirst = ""
Set rng = Nothing
vntRet = Application.CountIf(.Columns(cLngSearchColumn), vntAuflauf(lngI, cLngCriteriaColumn))
Redim vntOut(1 To vntRet + 1, 1 To Application.Max(cLngLastColumn, UBound(vntAuflauf, 2)))
For lngC = 1 To UBound(vntAuflauf, 2)
vntOut(1, lngC) = vntAuflauf(lngI, lngC)
Next
If vntRet > 0 Then
Set rng = .Columns(cLngSearchColumn).Find(What:=vntAuflauf(lngI, cLngCriteriaColumn), LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False, After:=.Cells(1, 4))
If Not rng Is Nothing Then
strFirst = rng.Address
Do
lngR = lngR + 1
For lngC = 1 To cLngLastColumn
vntOut(lngR, lngC) = .Cells(rng.Row, lngC).Value
Next
Set rng = .Columns(cLngSearchColumn).FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> strFirst
End If
End If
objSh.Cells(lngInsert, 1).Resize(UBound(vntOut, 1), UBound(vntOut, 2)) = vntOut
objSh.Cells(lngInsert, 1).Resize(1, UBound(vntOut, 2)).Font.Bold = True
lngInsert = lngInsert + UBound(vntOut, 1) + 1
Next
End With
objSh.Columns.AutoFit
objSh.Activate
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - zusammenfassung"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
End With
Set objSh = Nothing
Set rng = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function