title image


Smiley Da ist sie schon!
Hi,







Sub MonatsauswertungKfz()



'Achtung, die Inhalte der Spalten des Zielbereichs werden gelöscht!

'Sicherheitskopie anlegen



Dim lrow As Long, Ziel As Range, Monat As Range, Jahr As Range

Dim i As Long, j As Long, von As Long, bis As Long, lrow2 As Long



'Monat = InputBox("Für welchen Monat möchten Sie die Auswertung vornehmen?", "Monatszahl eingeben")

'Jahr = InputBox("Für welches Jahr möchten Sie die Auswertung vornehmen?", "Jahreszahl eingeben")



With Sheets("Auswertung_gesamt")



Set Ziel = .Range("B47") 'anpassen

Set Monat = .Range("H47") 'anpassen (Zelle, in der der Monat steht)

Set Jahr = .Range("I47") 'anpassen (Zelle, in der das Jahr steht)

lrow2 = .Cells(65536, Ziel.Column).End(xlUp).Row

.Range(Ziel, .Cells(lrow2, Ziel.Column + 2)).ClearContents

lrow = IIf(IsEmpty(Range("Gesamtübersicht!B65536")), Range("Gesamtübersicht!B65536").End(xlUp).Row, 65536)

Range("Gesamtübersicht!B15:B" & lrow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Ziel, Unique:=True

Range("Gesamtübersicht!K15:L15").Copy Ziel.Offset(0, 1)

For i = .Cells(65536, Ziel.Column).End(xlUp).Row To Ziel.Row + 1 Step -1

von = Range("Gesamtübersicht!B:B").Find(What:=Ziel.Offset(i - Ziel.Row), After:=Range("Gesamtübersicht!B1"), LookIn:=xlValues, _

LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row

bis = Range("Gesamtübersicht!B:B").Find(What:=Ziel.Offset(i - Ziel.Row), After:=Range("Gesamtübersicht!B65536"), LookIn:=xlValues, _

LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For j = bis To von Step -1

If Month(Range("Gesamtübersicht!K" & j)) = Monat And Year(Range("Gesamtübersicht!K" & j)) = Jahr Then

Ziel.Offset(i - Ziel.Row, 1) = Format(Range("Gesamtübersicht!K" & j), "dd.mm.yyyy")

Ziel.Offset(i - Ziel.Row, 2) = Range("Gesamtübersicht!L" & j)

Exit For

End If

If j = von Then .Range(Ziel.Offset(i - Ziel.Row, 0), Ziel.Offset(i - Ziel.Row, 2)).Delete

Next j

Next i

.Range(Ziel, Ziel.Offset(0, 2)).EntireColumn.AutoFit

.Activate

End With

End Sub







Code eingefügt mit Syntaxhighlighter 4.0




Gruß,



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: