AW: Häufigkeit von Feldeinträgen
27.02.2013 13:56:20
Feldeinträgen
Hi,
dieses Makro funktioniert in deiner Musterdatei. Ich habe es so geschrieben, dass man es möglichst einfach auf andere Dateien anpassen kann (dafur ist es etwas länger) und die wichtigsten Funktionen kommentiert.
Option Explicit
Sub Auflisten()
Dim wksSource As Worksheet
Dim wksTarget As Worksheet
Dim lRowSourceFrom As Long
Dim lRowSourceLast As Long
Dim lRowTargetFirst As Long
Dim iColSourceDate As Integer
Dim iColSourceName As Integer
Dim iColTargetName As Integer
Dim iColTargetNumm As Integer
Dim rBereich As Range
Dim rDatumVergleich As Range
Dim lTmpTargetRow As Long
Set wksSource = Sheets("Tabelle1") 'in dieser Tabelle stehen die Quellendaten
Set wksTarget = Sheets("Tabelle1") 'Hier soll die Auflistung hin ... gleiche Tabelle oder ne _
andere
Set rDatumVergleich = wksSource.Range("G3") 'hier steht das Vergleichsdatum!
lRowSourceFrom = 2 'Auswertenab Zeile 2 (Überschriften in Zeile 1)
iColSourceDate = 1 'Datums stehen in Spalte A (A=1, B=2 usw)
iColSourceName = 2 'Namen stehen in Spalte B (A=1, B=2 usw)
lRowTargetFirst = 7 'Ergebnisse ab Zeile 7
iColTargetName = 5 'Namen schreiben in Spalte E (A=1, B=2 usw)
iColTargetNumm = iColTargetName + 1 'Ergebnisse schreifen in Spalte F (A=1, B=2 usw) : muss 1 _
rechts vom Namen sein!
lTmpTargetRow = lRowTargetFirst
With wksSource
'letzte Zeile automatisch ermitteln
lRowSourceLast = .Cells(.Rows.Count, iColSourceName).End(xlUp).Row
For Each rBereich In .Range(.Cells(lRowSourceFrom, iColSourceName), .Cells(lRowSourceLast, _
iColSourceName))
'COUNTIF - kommt der Name das erste mal vor?
If Application.WorksheetFunction.CountIf(.Range(.Cells(lRowSourceFrom, iColSourceName), _
Cells(rBereich.Row, iColSourceName)), rBereich.Value) = 1 Then
'schreibe den Namen
wksTarget.Cells(lRowTargetFirst, iColTargetName).Value = rBereich.Value
'schreibe die Anzahl (ermittelt mit CountIfs - Excel 2010 !!
wksTarget.Cells(lRowTargetFirst, iColTargetNumm).Value = _
Application.WorksheetFunction.CountIfs(.Cells(1, iColSourceDate).EntireColumn, _
rDatumVergleich.Value, .Cells(1, iColSourceName).EntireColumn, rBereich.Value)
'erhöhe die nächste schreib-Zeile
lRowTargetFirst = lRowTargetFirst + 1
End If
Next rBereich
End With
'sortiere aufsteigend
With wksTarget
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range(.Cells(lTmpTargetRow - 1, iColTargetNumm), .Cells( _
lRowTargetFirst, iColTargetNumm)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Sort.SetRange .Range(.Cells(lTmpTargetRow - 1, iColTargetName), .Cells(lRowTargetFirst, _
iColTargetNumm))
With .Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Grüße,
Klaus M.vdT.