title image


Smiley Hier die Anpassungen
Guten Morgen,



ich habe dir hier eine Beispielmappe hochgeladen:



http://www.herber.de/bbs/user/33270.xls



Der angepasste Code sieht jetzt so aus:







Private Sub CommandButton1_Click()



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

'Sicherheitskopie anlegen



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

Dim i As Long, j As Long, von As Long, bis 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)



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

lrow = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row, 65536)

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

Range("K15:L15").Copy Ziel.Offset(0, 1)

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

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

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

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

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

    For j = bis To von Step -1

        If Month(Range("K" & j)) = Monat And Year(Range("K" & j)) = Jahr Then

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

            Ziel.Offset(i - Ziel.Row, 2) = Range("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: