AW: Filtern nach Monat mit Makro
03.04.2019 14:30:44
Nepumuk
Hallo Martin,
so besser?
Option Explicit
Public Sub Auswertung(ByVal strMonth As String)
Dim objDataObject As Object, objDictionary As Object
Dim strTempString As String
Dim avntTempRows As Variant, avntRow As Variant
Dim avntOutput As Variant
Dim ialngRow As Long, ialngCounter As Long
Dim lngRows As Long
With Tabelle1
With .Rows(3)
Call .AutoFilter(Field:=3, Criteria1:="Werkzeugproblem")
Call .AutoFilter(Field:=4, Operator:= _
xlFilterValues, Criteria2:=Array(1, CStr(Month(CDate("1." & _
strMonth & ".2000"))) & "/1/" & CStr(Year(Date))))
End With
If .Cells(.Rows.Count, 1).End(xlUp).Row = 3 Then
With Tabelle2
.Range(.Cells(4, 1), .Cells(.Rows.Count, 4)).ClearContents
End With
Call MsgBox(Prompt:="Keine Daten gefunden.", _
Buttons:=vbExclamation, Title:="Hinweis")
Exit Sub
End If
With .AutoFilter.Range
Range(.Cells(2, 2), .Cells(.Rows.Count, 8)).Copy
End With
End With
Set objDataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Call objDataObject.GetFromClipboard
strTempString = objDataObject.GetText
Set objDataObject = Nothing
Call Tabelle1.ShowAllData
strTempString = Left$(strTempString, Len(strTempString) - 2)
avntTempRows = Split(strTempString, vbCrLf)
Set objDictionary = CreateObject("Scripting.Dictionary")
For ialngRow = 0 To UBound(avntTempRows, 1)
avntRow = Split(avntTempRows(ialngRow), vbTab)
objDictionary.Item(avntRow(0)) = vbNullString
Next
lngRows = objDictionary.Count
Call objDictionary.RemoveAll
Redim avntOutput(0 To lngRows - 1, 0 To 2)
For ialngRow = 0 To UBound(avntTempRows, 1)
avntRow = Split(avntTempRows(ialngRow), vbTab)
If Not objDictionary.Exists(avntRow(0)) Then
Call objDictionary.Add(avntRow(0), ialngCounter)
avntOutput(ialngCounter, 0) = avntRow(0)
avntOutput(ialngCounter, 1) = 1
avntOutput(ialngCounter, 2) = CDbl(avntRow(6))
ialngCounter = ialngCounter + 1
Else
avntOutput(objDictionary.Item(avntRow(0)), 1) = _
avntOutput(objDictionary.Item(avntRow(0)), 1) + 1
avntOutput(objDictionary.Item(avntRow(0)), 2) = _
avntOutput(objDictionary.Item(avntRow(0)), 2) + CDbl(avntRow(6))
End If
Next
Set objDictionary = Nothing
With Application
.Calculation = xlCalculationManual
.CutCopyMode = False
.EnableEvents = False
.ScreenUpdating = False
End With
With Tabelle2
.Range(.Cells(4, 1), .Cells(.Rows.Count, 4)).ClearContents
.Range(.Cells(4, 2), .Cells(lngRows + 3, 4)).Value = avntOutput
Call .Sort.SortFields.Clear
Call .Sort.SortFields.Add(Key:=.Cells(3, 4), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal)
Call .Sort.SetRange(Rng:=.Range(.Cells(3, 2), .Cells(.Rows.Count, 4)))
With .Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Cells(4, 1).Value = 1
Call .Range(.Cells(4, 1), .Cells(lngRows + 3, 1)).DataSeries( _
RowCol:=xlColumns, Type:=xlDataSeriesLinear)
End With
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Gruß
Nepumuk