Sub artikel_verkauf()
Dim i As Long, j As Long
Dim lpMaxLine As Long
Dim lpCount As Long
Dim lpNumber As Long
Dim lpWord As String
Dim WS As Worksheet, WR As Worksheet
Dim lArray() As String
Dim bFound As Boolean
Dim ResultWS As String
Dim objWorksheet As Worksheet
Set WS = ThisWorkbook.Worksheets(ThisWorkbook.ActiveSheet.Name)
ResultWS = "Artikelverkauf"
For Each objWorksheet In ActiveWorkbook.Worksheets
If objWorksheet.Name = ResultWS Then
MsgBox ("Ergebnistabelle " & ResultWS & " ist bereits vorhanden. Bitte löschen oder umbenennen und Makro erneut ausführen.")
Exit Sub
End If
Next
Sheets.Add
ActiveSheet.Name = "Artikelverkauf"
Set WR = ThisWorkbook.Worksheets("Artikelverkauf")
lpMaxLine = WS.Range("A:Z").SpecialCells(xlCellTypeLastCell).Row
For i = 1 To lpMaxLine
lpWord = WS.Cells(i, 7)
bFound = False
For j = 1 To lpCount
If lArray(1, j) = lpWord Then
lArray(2, j) = lArray(2, j) + 1
bFound = True
End If
Next j
If Not bFound Then
lpCount = lpCount + 1
ReDim Preserve lArray(1 To 2, 1 To lpCount)
lArray(1, lpCount) = lpWord
lArray(2, lpCount) = 1
End If
Next i
For i = 1 To lpCount
WR.Cells(i, 1) = lArray(1, i)
WR.Cells(i, 2) = lArray(2, i)
Next i
End Sub