AW: Zellen zw. Blättern kopieren wenn Jahr/Monat
06.05.2014 10:07:49
UweD
Hallo
- Vorab folgende Formeln in Blatt 1 einbauen (in M40 und nach rechts kopieren)
=DATUM($N$22;SPALTE(A1);1)
- Das Makro auf die Dropbox legen
Rechtsclick auf die Dropbox
"Makro zuweisen"
Sub Dropdown1_BeiÄnderung()
On Error GoTo Fehler
Dim Jahr, D2 As Date
Dim TB1, TB2, i%, j%
Dim SP1%, SP2%, ZE&, ZL&, ZEK&, LR&
'*** Stammdaten Anfang
Set TB1 = ActiveSheet
Set TB2 = Sheets(3)
SP1 = 13
SP2 = 13
ZEK = 40 'Kopfzeile
ZE = 41 'Einfügen ab Zeile
ZL = ZE + 250 ' Anz Zeilen zum Einfügen
'*** Stammdaten Ende
Jahr = TB1.Range("N22")
LR = TB2.Cells(Rows.Count, SP2).End(xlUp).Row 'letzte Zeile der Spalte
TB1.Rows(ZE & ":" & ZL).ClearContents 'reset
For i = 4 To LR
For j = SP1 To SP1 + 11
D2 = Application.Min(TB1.Cells(ZEK, j + 1), CDate("31.12." & Jahr))
If TB2.Cells(i, SP2) >= TB1.Cells(ZEK, j) And TB2.Cells(i, SP2) "" Then TB1.Cells(ZE, j) = TB2.Cells(i, SP2 + 1)
End If
Next j
Next i
'*** Fehlerbehandlung
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
Clear
End Sub
Leere Zellwerte werden übergangen
Gruß UweD