VBA - Zahlen streichen

  • Excel

Es gibt 1 Antwort in diesem Thema. Der letzte Beitrag () ist von fari.

    VBA - Zahlen streichen

    Hallo Experten,

    ich habe eine Tabelle (siehe Anhang) aus der ich aus den Spalten M und N alle Fehler kleiner 2 streichen möchte und anstelle dieser eine Null reinschreiben möchte.

    Danach soll der Vergleichsalgorithmus gestartet werden, um die Bewertung zu erhalten:

    Visual Basic-Quellcode

    1. Public Sub BewertungInlineCT()
    2. Dim arrY As Variant, arrG As Variant, arrP As Variant
    3. Dim r As Long, y As Integer, g As Integer, reslt As Integer
    5. '***Geschwindigkeitsoptimierung Anfang
    6. Application.ScreenUpdating = False
    7. Application.Calculation = xlCalculationManual
    9. '***Auswertung durchführen
    10. With Worksheets("BewertungInlineCT")
    11. For r = 3 To 12
    13. '***Einlesen Zeile Y=Yellow, G=Green, P=Purple
    14. arrY = .Cells(r, "H").Resize(1, 4)
    15. arrG = .Cells(r, "M").Resize(1, 2)
    16. arrP = .Cells(r, "Q").Resize(1, 2)
    18. '***Auswerten "Anzahl Fehler" Yellow
    19. reslt = 0
    20. For y = 1 To UBound(arrY, 2) Step 2
    21. If arrY(1, y) > 0 Or arrY(1, y + 1) > 0 Then reslt = reslt + 1
    22. Next y
    23. .Cells(r, "G") = reslt
    25. '***Auswerten "Anzahl Fehler" Green
    26. reslt = 0
    27. For g = 1 To UBound(arrG, 2)
    28. If arrG(1, g) > 0 Then reslt = reslt + 1
    29. Next g
    30. .Cells(r, "L") = reslt
    34. '***Auswerten "Anzahl richtig"
    35. reslt = 0
    36. For g = 1 To UBound(arrG, 2)
    37. If arrG(1, g) <> 0 And Not IsEmpty(arrG(1, g)) Then
    38. For y = 1 To UBound(arrY, 2) Step 2
    39. If arrG(1, g) >= (arrY(1, y) - 2) And arrG(1, g) <= (arrY(1, y + 1) + 2) Then
    40. reslt = reslt + 1
    41. arrY(1, y) = Empty: arrY(1, y + 1) = Empty
    42. arrG(1, g) = Empty
    43. Exit For
    44. End If
    45. Next y
    46. End If
    47. Next g
    48. .Cells(r, "D") = IIf(reslt > 0, reslt, "")
    50. '***Auswerten "Anzahl Schlupf"
    51. reslt = 0
    52. For g = 1 To UBound(arrG, 2)
    53. If arrG(1, g) <> 0 And Not IsEmpty(arrG(1, g)) Then
    54. reslt = reslt + 1
    55. arrG(1, g) = Empty
    56. End If
    57. Next g
    58. .Cells(r, "E") = IIf(reslt > 0, reslt, "")
    60. '***Auswerten "Anzahl Pseudo"
    61. reslt = 0
    62. For y = 1 To UBound(arrY, 2) Step 2
    63. If arrY(1, y) <> 0 And Not IsEmpty(arrY(1, y)) And _
    64. arrY(1, y + 1) <> 0 And Not IsEmpty(arrY(1, y + 1)) Then
    65. reslt = reslt + 1
    66. arrY(1, y) = Empty: arrY(1, y + 1) = Empty
    67. End If
    68. Next y
    69. .Cells(r, "F") = IIf(reslt > 0, reslt, "")
    71. '***Auswerten "Gesamtentscheid"
    72. .Cells(r, "B") = IIf(.Cells(r, "E") + .Cells(r, "F") > 0, 0, 1)
    73. Next r
    74. End With
    76. '***Geschwindigkeitsoptimierung Ende
    77. Application.ScreenUpdating = True
    78. Application.Calculation = xlCalculationAutomatic
    79. End Sub


    Um die Fehler zu filtern, habe ich vor dem Abschnitt Auswerten Anzahl richtig folgendes eingefügt

    Visual Basic-Quellcode

    1. For g = 1 To UBound(arrP, 2)
    2. If arrP(1, g) < 2 Then arrG(1, g) = "0"
    3. Next g


    Leider funktioniert das aber nicht!

    Kann mir einer bitte sagen, was ich falsch mache?

    Danke!

    Gruß fari
    Dateien

    • Test.xls

      (78,34 kB, 216 mal heruntergeladen, zuletzt: )