Makro erweitern

  • Excel

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

    Makro erweitern

    Hallo Experten,

    ich sitzte sehr lange vor einem Problem und kann es nicht lösen. Ich bin völlig unerfahren in VBA und bräuchte bitte Eure Hilfe.

    Es geht um folgendes Makro:

    Visual Basic-Quellcode

    1. Public Sub Tabelle1Auswertung()
    2. Dim arrY As Variant, arrG As Variant, arrR As Variant
    3. Dim r As Long, y As Integer, g As Integer, reslt As Integer
    5. '***ScreenUpdating
    6. Application.ScreenUpdating = False
    7. Application.Calculation = xlCalculationManual
    9. '***Auswertung durchführen
    10. With Worksheets("Tabelle1")
    11. For r = 3 To 9
    13. '***Einlesen Zeile
    14. arrY = .Cells(r, "H").Resize(1, 6)
    15. arrG = .Cells(r, "P").Resize(1, 3)
    16. arrR = .Cells(r, "V").Resize(1, 3)
    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, "O") = reslt
    32. '***Auswerten "Anzahl richtig"
    33. reslt = 0
    34. For g = 1 To UBound(arrG, 2)
    35. If arrG(1, g) <> 0 And Not IsEmpty(arrG(1, g)) Then
    36. For y = 1 To UBound(arrY, 2) Step 2
    37. If arrG(1, g) >= arrY(1, y) And arrG(1, g) <= arrY(1, y + 1) Then
    38. reslt = reslt + 1
    39. arrY(1, y) = Empty: arrY(1, y + 1) = Empty
    40. arrG(1, g) = Empty
    41. Exit For
    42. End If
    43. Next y
    44. End If
    45. Next g
    46. .Cells(r, "D") = IIf(reslt > 0, reslt, "")
    48. '***Auswerten "Anzahl Schlupf"
    49. reslt = 0
    50. For g = 1 To UBound(arrG, 2)
    51. If arrG(1, g) <> 0 And Not IsEmpty(arrG(1, g)) Then
    52. reslt = reslt + 1
    53. arrG(1, g) = Empty
    54. End If
    55. Next g
    56. .Cells(r, "E") = IIf(reslt > 0, reslt, "")
    58. '***Auswerten "Anzahl Pseudo"
    59. reslt = 0
    60. For y = 1 To UBound(arrY, 2) Step 2
    61. If arrY(1, y) <> 0 And Not IsEmpty(arrY(1, y)) And _
    62. arrY(1, y + 1) <> 0 And Not IsEmpty(arrY(1, y + 1)) Then
    63. reslt = reslt + 1
    64. arrY(1, y) = Empty: arrY(1, y + 1) = Empty
    65. End If
    66. Next y
    67. .Cells(r, "F") = IIf(reslt > 0, reslt, "")
    69. '***Auswerten "Gesamtentscheid"
    70. .Cells(r, "B") = IIf(.Cells(r, "E") + .Cells(r, "F") > 0, 0, 1)
    71. Next r
    72. End With
    74. '***ScreenUpdating
    75. Application.ScreenUpdating = True
    76. Application.Calculation = xlCalculationAutomatic
    78. End Sub


    Die Auswertung soll nun die letzten 3 Spalten V-X (siehe Anhang), in denen die Größe der Fehler in den grünhinterlegten Spalten drinstehen, berücksichtigen. Immer wenn die Größe der Fehler kleiner 2 ist (z.B. 0,8 und 1) und nicht in H-M gefunden werden, dann soll dies nicht als Schlupf gewertet werden und somit auch nicht den Gesamtentscheid beeinflussen (z.B. wären das die Fehler R5 und P7).

    Als Erstes habe ich am Anfang ein neues array deklariert und es "arrR" genannt, wegen den rothinterlegten Spalten V-X. Danach habe ich in Abschnitt '***Einlesen Zeile dieses Array entsprechend hinzugefügt.
    Ich bin mir allerdings nicht sicher, ob ich für diese Erweiterung ein neues Array überhaupt brauche?

    Als Nächstes habe ich in dem Abschnitt '***Auswerten "Anzahl Schlupt" vieles ausprobiert und nichts klappt (u.a. habe ich es mit einer Elseif-Schleife erfolglos probiert).

    Die Excel Tabelle zusammen mit dem Makro schicke ich Euch als Anhang.

    Ich hoffe Ihr könnt mir weiterhelfen.

    Danke!

    Gruß salva
    Dateien

    • Test.xls

      (46,08 kB, 175 mal heruntergeladen, zuletzt: )

    Hallo,

    ich glaub, ich habe es geschafft!

    Hoffe es funktioniert! Muss es nur noch ausgiebig testen.

    Hab dafür den Code folgendermaßen erweitert:

    Quellcode

    1. Public Sub Tabelle1Auswertung()
    2. Dim arrY As Variant, arrG As Variant, arrR As Variant
    3. Dim r As Long, y As Integer, g As Integer, reslt As Integer
    5. '***ScreenUpdating
    6. Application.ScreenUpdating = False
    7. Application.Calculation = xlCalculationManual
    9. '***Auswertung durchführen
    10. With Worksheets("Tabelle1")
    11. For r = 3 To 9 '.Range("H" & Rows.Count).End(xlUp).Row
    13. '***Einlesen Zeile
    14. arrY = .Cells(r, "H").Resize(1, 6)
    15. arrG = .Cells(r, "P").Resize(1, 3)
    16. arrR = .Cells(r, "V").Resize(1, 3)
    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, "O") = reslt
    32. '***Auswerten "Anzahl richtig"
    33. reslt = 0
    34. For g = 1 To UBound(arrG, 2)
    35. If arrG(1, g) <> 0 And Not IsEmpty(arrG(1, g)) Then
    36. For y = 1 To UBound(arrY, 2) Step 2
    37. If arrG(1, g) >= arrY(1, y) And arrG(1, g) <arrY> 0, reslt, "")
    39. '***Auswerten "Anzahl Schlupf"
    40. reslt = 0
    41. For g = 1 To UBound(arrG, 2)
    42. If arrG(1, g) <> 0 And Not IsEmpty(arrG(1, g)) And arrR(1, g) > 2 Then
    43. reslt = reslt + 1
    44. arrG(1, g) = Empty
    45. End If
    46. Next g
    47. .Cells(r, "E") = IIf(reslt > 0, reslt, "")
    49. '***Auswerten "Anzahl Pseudo"
    50. reslt = 0
    51. For y = 1 To UBound(arrY, 2) Step 2
    52. If arrY(1, y) <> 0 And Not IsEmpty(arrY(1, y)) And _
    53. arrY(1, y + 1) <> 0 And Not IsEmpty(arrY(1, y + 1)) Then
    54. reslt = reslt + 1
    55. arrY(1, y) = Empty: arrY(1, y + 1) = Empty
    56. End If
    57. Next y
    58. .Cells(r, "F") = IIf(reslt > 0, reslt, "")
    60. '***Auswerten "Gesamtentscheid"
    61. .Cells(r, "B") = IIf(.Cells(r, "E") + .Cells(r, "F") > 0, 0, 1)
    62. Next r
    63. End With
    65. '***ScreenUpdating
    66. Application.ScreenUpdating = True
    67. Application.Calculation = xlCalculationAutomatic
    69. End Sub


    Ich habe einfach ein neues array deklariert und im Abschnitt '***Auswerten "Anzahl Schlupf" die Erweiterung And arrR(1, g) > 2 hinzugefügt. :)

    Gruß salva

Facebook
Telefonspende