AW: Code ändern
11.04.2016 09:41:02
hary
Moin
Teste mal.Es wird eine Hilfsspalte(I)erstellt und wieder gloescht.
Private Sub CommandButton1_Click()
Dim i As Long, myLastRow2 As Long, Monat As Long
Dim Zelle As Range
Dim a As Variant
Dim wksQ As Worksheet, wksZ As Worksheet, wksJahr As Worksheet
Set wksQ = Worksheets("Hilfstabelle")
Set wksZ = Worksheets("Grundbuch")
Set wksJahr = Worksheets("Jahresauswertung")
Application.ScreenUpdating = False
wksQ.Range("G1") = "Hilfsspalte"
wksQ.Range("G2:G" & wksQ.Cells(Rows.Count, 1).End(xlUp).Row).FormulaLocal = "=SUMME(D2:F2)"
With wksQ.Range("A1").CurrentRegion
.AutoFilter Field:=7, Criteria1:=">0"
i = Intersect(.SpecialCells(xlVisible), .Columns(1)).Count - 1
If i > 0 Then
myLastRow2 = Application.Max(4, wksZ.Cells(Rows.Count, 3).End(xlUp).Row + 1)
.Range("A2:F" & .Cells(Rows.Count, 3).End(xlUp).Row).SpecialCells(xlVisible).Copy
wksZ.Range("C" & myLastRow2).PasteSpecial Paste:=xlValue
wksZ.Range("B" & myLastRow2).Resize(wksZ.Cells(Rows.Count, 3).End(xlUp).Row - _
myLastRow2 + 1, 1) = Date
Monat = Month(wksZ.Range("B4"))
For Each Zelle In wksZ.Range("C4:C" & wksZ.Cells(Rows.Count, 3).End(xlUp).Row)
a = Application.Match(Zelle, wksJahr.Columns(1), 0)
If IsNumeric(a) Then
wksJahr.Cells(a, 3 * Monat + 1) = wksJahr.Cells(a, 3 * Monat + 1) + Zelle. _
Offset(, 3)
wksJahr.Cells(a, 3 * Monat + 2) = wksJahr.Cells(a, 3 * Monat + 2) + Zelle. _
Offset(, 4)
wksJahr.Cells(a, 3 * Monat + 3) = wksJahr.Cells(a, 3 * Monat + 3) + Zelle. _
Offset(, 5)
End If
Next
End If
Application.CutCopyMode = False
.AutoFilter
End With
wksQ.Columns(7).Clear
Application.ScreenUpdating = True
Set wksQ = Nothing
Set wksZ = Nothing
End Sub