prüfen sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub checkDateandSort() Dim rng As Range With Sheets("Tabelle1") 'Tabellenname anpassen! With .Range("A1").CurrentRegion Set rng = .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1) If Application.CountA(rng) = Application.Count(rng) Then .Sort Key1:=.Cells(1, 3), Order1:=xlAscending, Header:=xlYes Else Set rng = rng.SpecialCells(xlCellTypeConstants, 2) rng.Interior.Color = vbRed MsgBox "Es befinden sich Textwerte in Spalte C!" Application.Goto rng End If End With End With Set rng = Nothing End Sub

Hallo Sepp und Peter,
es ist immer wieder erstaunlich wie schnell ihr so etwas aus dem ärmel schüttelt.
Habt recht vielen dank beide Macros sind sau schnell und zuverlässig. Die Idee die stellen gleich zu färben ist natürlich auch cool.
Jedoch wie es immer so ist bekommt man noch eine Prüfung mit rein?
Ich habe gerade festgestellt das ich noch die Spalte B prüfen muss ob die Werte positiv und sich kein #WERT! darin befindet.
Falls ein wert negativ ist oder ein Fehlerwert in der Spalte ist sollen wieder die betroffenen Stellen markiert und gemeldet werden.
Dazu habe ich ein teilmacro gefunden aber ich bekomme es in keins von beiden integriert.
könnt ihr noch mal schauen?
liebe grüsse thomas
Dim rngCell As Range
Set rngCell = .Columns(2).Offset(1, 0).Resize(.Rows.Count - 1, 1)
If rngCell.Value 0 Then
MsgBox "Bitte rote Zellen beachten !"

Sub checkDateandSort() Dim rng As Range, rngF As Range, rngC As Range With Sheets("Tabelle1") 'Tabellenname anpassen! With .Range("A1").CurrentRegion Set rng = .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1) If Application.CountA(rng) = Application.Count(rng) Then Set rng = Nothing Set rng = .Columns(2).Offset(1, 0).Resize(.Rows.Count - 1, 1) On Error Resume Next Set rngF = rng.SpecialCells(xlCellTypeFormulas, 16) On Error GoTo 0 If Application.CountA(rng) <> Application.Count(rng) Or _ Application.CountIf(rng, "<0") > 0 Or Not rngF Is Nothing Then For Each rngC In rng.SpecialCells(xlCellTypeFormulas, 1) If rngC < 0 Then If rngF Is Nothing Then Set rngF = rngC Else Set rngF = Union(rngF, rngC) End If End If Next rngF.Interior.Color = vbRed MsgBox "Es befinden sich Fehler- oder Minus-Werte in Spalte B!" Application.Goto rngF Else .Sort Key1:=.Cells(1, 3), Order1:=xlAscending, Header:=xlYes End If Else Set rng = rng.SpecialCells(xlCellTypeConstants, 2) rng.Interior.Color = vbRed MsgBox "Es befinden sich Textwerte in Spalte C!" Application.Goto rng End If End With End With Set rng = Nothing End Sub

Sub Sepp_sortieren2() Dim rng As Range, rngF As Range, rngC As Range With Sheets("Tabelle1") 'Tabellenname anpassen! With .Range("A1").CurrentRegion Set rng = .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1) If Application.CountA(rng) = Application.Count(rng) Then Set rng = Nothing Set rng = .Columns(2).Offset(1, 0).Resize(.Rows.Count - 1, 1) On Error Resume Next Set rngF = rng.SpecialCells(xlCellTypeConstants, 16) On Error GoTo 0 If Application.CountA(rng) <> Application.Count(rng) Or _ Application.CountIf(rng, "<0") > 0 Or Not rngF Is Nothing Then For Each rngC In rng.SpecialCells(xlCellTypeConstants, 1) If rngC < 0 Then If rngF Is Nothing Then Set rngF = rngC Else Set rngF = Union(rngF, rngC) End If End If Next rngF.Interior.Color = vbRed MsgBox "Es befinden sich Fehler- oder Minus-Werte in Spalte B!" Application.Goto rngF Else .Sort Key1:=.Cells(1, 3), Order1:=xlAscending, Header:=xlYes End If Else Set rng = rng.SpecialCells(xlCellTypeConstants, 2) rng.Interior.Color = vbRed MsgBox "Es befinden sich Textwerte in Spalte C!" Application.Goto rng End If End With End With Set rng = Nothing End Sub

Hallo Thomas,
das der Fehler nur auftritt wenn in C alles OK ist, ist klar, weil B nur dann geprüft wird.
Probier es unter mal so.

Sub Sepp_sortieren2()
Dim rng As Range, rngF As Range, rngC As Range

With Sheets("Tabelle1") 'Tabellenname anpassen!
  With .Range("A1").CurrentRegion
    Set rng = .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1)
    If Application.CountA(rng) = Application.Count(rng) Then
      Set rng = Nothing
      Set rng = .Columns(2).Offset(1, 0).Resize(.Rows.Count - 1, 1)
      If Application.CountIf(rng, CVErr(xlErrValue)) > 0 Or Application.CountA(rng) > 0 Then
        On Error Resume Next
        Set rngF = rng.SpecialCells(xlCellTypeConstants, 18)
        Err.Clear
        On Error GoTo 0
      End If
      If Application.CountA(rng) <> Application.Count(rng) Or Application.CountIf(rng, "<0") > 0 Then
        For Each rngC In rng.SpecialCells(xlCellTypeConstants, 1)
          If rngC < 0 Then
            If rngF Is Nothing Then
              Set rngF = rngC
            Else
              Set rngF = Union(rngF, rngC)
            End If
          End If
        Next
        rngF.Interior.Color = vbRed
        MsgBox "Es befinden sich Fehler- oder Minus-Werte in Spalte B!"
        Application.Goto rngF
      Else
        .Sort Key1:=.Cells(1, 3), Order1:=xlAscending, Header:=xlYes
      End If
    Else
      Set rng = rng.SpecialCells(xlCellTypeConstants, 2)
      rng.Interior.Color = vbRed
      MsgBox "Es befinden sich Textwerte in Spalte C!"
      Application.Goto rng
    End If
  End With
End With

Errorhandler:

Set rng = Nothing
End Sub

Gruß Sepp

Option Explicit Public Sub Pruefen_sortieren() Dim lLetzte As Long Dim lZeile As Long Dim sText As String With ThisWorkbook.Worksheets("Tabelle3") ' den Tabellenblattnamen ggf. anpassen! lLetzte = .Cells(.Rows.Count, 3).End(xlUp).Row For lZeile = 2 To lLetzte If Not IsDate(.Range("C" & lZeile).Value) Then If sText = "" Then sText = "kein oder fehlerhaftes Datum in Zeile" & vbLf & vbLf & lZeile Else sText = sText & vbLf & lZeile End If End If Next lZeile If sText "" Then MsgBox sText Exit Sub End If .Range("A2:X" & lLetzte).Sort _ Key1:=.Range("C2"), Order1:=xlAscending, _ Header:=xlNo, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom End With End Sub

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread