Makro Daten älter als 2 Monate in anderes Register

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub archivieren() Dim objSh As Worksheet, objArchiv As Worksheet Dim rng As Range Dim lngRow As Long, lngLast As Long If SheetExist(CStr(Year(Date))) Then Set objSh = Sheets(CStr(Year(Date))) Set objArchiv = Sheets("Archiv") With objSh lngLast = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) For lngRow = 3 To lngLast If .Cells(lngRow, 1).Interior.ColorIndex = xlNone And .Cells(lngRow, 1) < _ DateSerial(Year(Date), Month(Date) - 2, Day(Date)) Then If rng Is Nothing Then Set rng = .Rows(lngRow) Else Set rng = Union(rng, .Rows(lngRow)) End If End If Next End With If Not rng Is Nothing Then rng.Copy objArchiv.Cells(objArchiv.Rows.Count, 1).End(xlUp).Offset(1, 0) rng.Delete End If End If Set rng = Nothing Set objSh = Nothing Set objArchiv = Nothing End Sub Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean Dim wks As Worksheet On Error GoTo ERRORHANDLER If Wb Is Nothing Then Set Wb = ThisWorkbook For Each wks In Wb.Worksheets If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function Next ERRORHANDLER: SheetExist = False End Function

Hallo Sepp
Anbei das Makro BedingteFormatierung:
' BedingteFormatierungErstellenNeu Makro
'
'
Selection.End(xlUp).Select
Range("A814").Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A3:T1048576").Select
Cells.FormatConditions.Delete
Range("A3:T1048576").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$N3:$N3="""""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = True
Range("A3:T1048576").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$K3:$K3="""""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 12611584
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = True
Range("A3:T1048576").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$B3:$B3="""""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).StopIfTrue = True
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Offset(1, 0).Select
End Sub
Bei :
- Eingabe in Spalte B = ganze Zeile blau
- Eingabe in Spalte K = ganze Zeile rot
- Eingabe in Spalte N = ganze Zeile "keine Markierung"
Sorry, soweit habe ich gar nicht gedacht. Farbe gleich Farbe, was soll's :-(
Gruss Markus

Hallo Markus,

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub archivieren()
  Dim objSh As Worksheet, objArchiv As Worksheet
  Dim rng As Range
  Dim lngRow As Long, lngLast As Long
  
  If SheetExist(CStr(Year(Date))) Then
    Set objSh = Sheets(CStr(Year(Date)))
    Set objArchiv = Sheets("Archiv")
    With objSh
      lngLast = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row)
      For lngRow = 3 To lngLast
        If .Cells(lngRow, 14) <> "" And .Cells(lngRow, 1) < _
          DateSerial(Year(Date), Month(Date) - 1, Day(Date)) And _
          Not (.Cells(lngRow, 2) = "" Or .Cells(lngRow, 11) = "") Then
          If rng Is Nothing Then
            Set rng = .Rows(lngRow)
          Else
            Set rng = Union(rng, .Rows(lngRow))
          End If
        End If
      Next
    End With
    If Not rng Is Nothing Then
      rng.Copy objArchiv.Cells(objArchiv.Rows.Count, 1).End(xlUp).Offset(1, 0)
      rng.Delete
    End If
  End If
  
  Set rng = Nothing
  Set objSh = Nothing
  Set objArchiv = Nothing
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function


Sub BedingteFormatierungErstellenNeu()
  
  With Range("A3:T" & Application.Max(3, Cells(Rows.Count, 1).End(xlUp).Row))
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:="=UND($K3<>"""";$N3="""")"
    .FormatConditions(1).Interior.Color = 12611584
    .FormatConditions(1).StopIfTrue = True
    .FormatConditions.Add Type:=xlExpression, Formula1:="=UND($B3<>"""";$N3="""")"
    .FormatConditions(2).Interior.Color = 255
    .FormatConditions(2).StopIfTrue = True
  End With
  
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Makro Daten älter als 2 Monate in anderes Register

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread