AW: Kundennamen zählen
03.12.2011 18:11:09
Ass
Hallo Kai,
vielleicht geht's so:
am Ende wird mit
Sheets("Übersicht").Cells.Clear
der gesamte Inhalt des Blattes gelöscht
schau's dir mal an.
Sub KopiePakete2()
Const TextMode = 1
Dim MyDic As Object, varKey, Bereich As Range, Zelle As Range
Dim dDatum As Date, i As Long, sNeukunde As String
With Sheets("Übersicht")
Set Bereich = .Range("c1:c" & .Range("c65536").End(xlUp).Row)
dDatum = .Range("a1").Value
End With
Set MyDic = CreateObject("Scripting.Dictionary")
MyDic.CompareMode = TextMode
'Liste erstellen mit allen Kunden und der Anzahl ihrer Pakete
For Each Zelle In Bereich.Cells
If Not IsEmpty(Zelle) Then
If MyDic.Exists(Zelle.Text) Then
MyDic(Zelle.Text) = MyDic(Zelle.Text) + 1
Else
MyDic.Add Zelle.Text, 1
End If
End If
Next
'Ausgabe
On Error GoTo FEHLER
If MyDic.Count > 0 Then
For Each varKey In MyDic
i = MyDic(varKey)
With Sheets(varKey) 'Fehler wenn Kunde nicht bekannt
Set Zelle = .Cells(.Range("a65536").End(xlUp).Row, 1)
If Not Zelle.Value = dDatum Then
Zelle.Offset(1, 0) = dDatum
Zelle.Offset(1, 1) = i
End If
WEITER:
End With
Next
End If
Set MyDic = Nothing
Set Bereich = Nothing
Set Zelle = Nothing
MsgBox sNeukunde & "neu angelegt."
Sheets("Übersicht").Cells.Clear
Exit Sub
FEHLER:
sNeukunde = sNeukunde & varKey & vbCrLf
NeuerPaketkunde varKey, i, dDatum
Err.Clear
Resume WEITER
End Sub
Sub NeuerPaketkunde(ByVal Kunde As String, Pakete As Long, pDatum As Date)
Dim ws As Object
On Error Resume Next
Set ws = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
'Übernahme des Tabellenkopfes aus dem Tabellenblatt"Kunde 1"
'welches hoffentlich vorhanden ist
.Name = Kunde
.Range("a1") = Sheets("Kunde 1").Range("a1")
.Range("a2") = Kunde
.Range("a4:b4").Value = Sheets("Kunde 1").Range("a4:b4").Value
.Range("a5") = pDatum
.Range("b5") = Pakete
End With
End Sub
Gruß
Rudi