Ursprüngliche Zahlen finden?

[schauan]

Hallöchen,

ich hab mir auch gedacht, von unten zu beginnen. Allerdings komme ich in Zeile 8 auf 8, wenn ich den Bereich immer bis Zeile 1 durchsuche.

Also, gesucht ist die Zahl für AN8

Zeile 8: 22 ist offen, weil zuvor nicht markiert
Zeile 7: 11 ist belegt, weil zuvor in Zeile 4 markiert
Zeile 6: nichts zu prüfen
Zeile 5: 12 ist belegt, weil zuvor in Zeile 3 markiert
Zeile 5: 16 ist offen, weil zuvor nicht markiert
Zeile 4: nichts zu prüfen
Zeile 3: 11 wird nicht bewertet, weil weiter oben schon
Zeile 3: 19 ist offen, weil als Suchzahl nicht eingefärbt
Zeile 2 : 8 ist offen ...
Zeile 2 : 18 ist offen ...
Zeile 2: 12 wird nicht bewertet, weil weiter oben schon
Zeile 1: 3x offen, weils ja keine Zeile 0 gibt ...

Ich komme also auf 8x offen.


Das wäre der code dafür:

Public Function CountColored3(iCalRow As Long) As Long
'Variablendeklarationen 
Dim cCount&, iCntC&, iCntR&, iColI&
Dim rngCells As Range
Dim bolTref As Boolean
Dim colNumb As Collection, colRows As Collection
Set colNumb = New Collection
Set colRows = New Collection
'Funktion in Zeile 1 mit Wert 0 verlassen 
If iCalRow = 1 Then CountColored3 = 0: Exit Function
'Alle zu pruefenden Zahlen im Bereich O:Z aufnehmen 
Set rngCells = Range("O1:Z" & iCalRow)
'Zahlen aufnehmen 
With rngCells
  Redim arrColR(1 To .Rows.Count)
  'Schleife ueber alle Zeilen des Bereichs 
  For iCntR = .Rows.Count To 1 Step -1
    iColI = colNumb.Count
    'Schleife ueber alle Zellen des Bereiches 
    For Each Zellen In .Rows(iCntR).Cells
      'Wenn nix in der Zelle steht, dann Schleife verlassen 
      'und weiter mit naechster Zeile 
      If Zellen.Value = "" Then Exit For
      'Wenn der Farbindex <> keine Fuellung ist, dann Zahl uebernehmen 
      If Zellen.Interior.Color <> Range("AO1").Interior.Color Then
        'Bei Fehler weiter mit naechster Codezeile 
        On Error Resume Next
          'Zahl hinzufuegen, Fehler, wenn schon enthalten 
          colNumb.Add Zellen.Value, CStr(Zellen.Value)
          'Wenn kein Fehler, dann Zeilennummer merken 
          If Err = 0 Then colRows.Add iCntR
        'Fehlerbehandlung Ende 
        On Error GoTo 0
      'Oder Wenn der Farbindex = keine Fuellung ist, dann 
      Else
        'offene hochzaehlen 
        cCount = cCount + 1
      End If
    'Ende Schleife ueber alle Zellen des Bereiches 
    Next
  'Ende Schleife ueber alle Zeilen des Bereichs 
  Next
End With
'Auszaehlen 
'Schleife ueber alle collectioneintraege 
For iColI = 1 To colNumb.Count
  'Wenn Zeilennumer = 1, dann 
  'In Zeile 1 sind alle offen 
  If colRows(iColI) = 1 Then
  'Wenn Zeilennumer = 1, dann 
    cCount = cCount + 1
  'Alternativ zu Wenn Zeilennumer = 1, dann 
  Else
    'Wenn Suchzahl nicht im Bereich ist, dann 
    If WorksheetFunction.CountIf(Range("D1:I" & colRows(iColI) - 1), colNumb(iColI)) = 0 Then
      cCount = cCount + 1
      Debug.Print colNumb(iColI) & vbTab & colRows(iColI) - 1 & vbTab & 0
    'Alternativ zu Wenn Suchzahl nicht im Bereich ist, dann 
    Else
      'Schleife ueber alle Collectioneintraege 
      For iCntR = colRows(iColI) - 1 To 1 Step -1
        'Treffervariable auf false setzen 
        bolTref = False
        'Schleife ueber die Eintraege der Zeile in Spalten D:I 
        For iCntC = 4 To 9
          'Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Telle eingefaerbt ist, dann 
          If Cells(iCntR, iCntC).Value = colNumb(iColI) And Cells(iCntR, iCntC).Interior.ColorIndex <> xlNone Then
           'Treffervariable auf true setzen 
            bolTref = True
            'Schleife verlassen 
            Exit For
          'Ende Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Telle eingefaerbt ist, dann 
          End If
        'Ende Schleife ueber die Eintraege der Zeile in Spalten D:I 
        Next
        'Wenn Treffervariable true, dann Schleife verlassen 
        If bolTref = True Then Exit For
      'Ende Schleife ueber alle Collectioneintraege 
      Next
      If bolTref = False Then
        cCount = cCount + 1
        Debug.Print colNumb(iColI) & vbTab & colRows(iColI) - 1 & vbTab & 1
      End If
    'Ende Wenn Suchzahl nicht im Bereich ist, dann 
    End If
  'Ende Wenn Zeilennumer = 1, dann 
  End If
'Ende Schleife ueber alle collectioneintraege 
Next
'Counter an Funktionswert geben 
CountColored3 = cCount
End Function

Sub test()
MsgBox CountColored3(8)
End Sub

[Angelina]

hallo

Also, gesucht ist die Zahl für AN8


Zeile 8: 22 ist offen, weil zuvor nicht markiert

richtig

Zeile 7: 11 ist belegt, weil zuvor in Zeile 4 markiert

richtig

Zeile 6: nichts zu prüfen

richtig

Zeile 5: 12 ist belegt, weil zuvor in Zeile 3 markiert
falsch

warum falsch?
Diese 12 in Zeile 3 wurde in Zeile 2 O:Z prognostiziert
in Abhängigkeit von dem AM1 Wert 5
Das bedeutet, das diese 12 aus Zeile 2 O:Z in
Zeile 2,3,4,5 kommen soll/wird (D:I)

Also hat diese 12 nichts mit der anderen 12 zu tun

Zeile 5: 16 ist offen, weil zuvor nicht markiert

richtig

Zeile 4: nichts zu prüfen

richtig

Zeile 3: 11 wird nicht bewertet, weil weiter oben schon

richtig

Zeile 3: 19 ist offen, weil als Suchzahl nicht eingefärbt

richtig

Zeile 2 : 8 ist offen ...

falsch - weil in Zeile 3 vorgekommen

Zeile 2 : 18 ist offen ...

falsch - weil in Zeile 3 vorgekommen

Zeile 2: 12 wird nicht bewertet, weil weiter oben schon

falsch 

Zeile 1: 3x offen, weils ja keine Zeile 0 gibt ...

falsch - 26 kam in Zeile 4 - 39 kam in Zeile 6 - 47 kam in Zeile 7

Ich komme also auf 8x offen.

falsch
4 x offen
19,12,16,22


LG
Angelina

[schauan]

Hallo Angelina,

erst mal ohne die Bedingung aus AM würde das dann ein Ergebnis liefern. Allerdings hab ich jetzt 3 in Zeile 8, wegen der Sache mit der 12. Die muss ich mir noch durchdenken. Der code liefert übrigens erst mal in dem Testaufruf nur eine Meldung mit dem Ergebnis. Dauert wieder etwas bis zum nächsten Step, bin jetzt erst mal unterwegs.

Public Function CountColored4(iCalRow As Long) As Long
'Variablendeklarationen 
Dim cCount&, iCntC&, iCntR&, iColI&
Dim rngCells As Range
Dim bolTref As Boolean
Dim colNumb As Collection, colRows As Collection
Set colNumb = New Collection
Set colRows = New Collection
'Funktion in Zeile 1 mit Wert 0 verlassen 
If iCalRow = 1 Then CountColored3 = 0: Exit Function
'Alle zu pruefenden Zahlen im Bereich O:Z aufnehmen 
Set rngCells = Range("O1:Z" & iCalRow)
'Zahlen aufnehmen 
With rngCells
  Redim arrColR(1 To .Rows.Count)
  'Schleife ueber alle Zeilen des Bereichs 
  For iCntR = .Rows.Count To 1 Step -1
    iColI = colNumb.Count
    'Schleife ueber alle Zellen des Bereiches 
    For Each Zellen In .Rows(iCntR).Cells
      'Wenn nix in der Zelle steht, dann Schleife verlassen 
      'und weiter mit naechster Zeile 
      If Zellen.Value = "" Then Exit For
      'Wenn der Farbindex <> keine Fuellung ist, dann Zahl uebernehmen 
      If Zellen.Interior.Color <> Range("AO1").Interior.Color Then
        'Bei Fehler weiter mit naechster Codezeile 
        On Error Resume Next
          'Zahl hinzufuegen, Fehler, wenn schon enthalten 
          colNumb.Add Zellen.Value, CStr(Zellen.Value)
          'Wenn kein Fehler, dann Zeilennummer merken 
          If Err = 0 Then colRows.Add iCntR
        'Fehlerbehandlung Ende 
        On Error GoTo 0
      'Oder Wenn der Farbindex = keine Fuellung ist, dann 
      Else
        'offene hochzaehlen 
        cCount = cCount + 1
      End If
    'Ende Schleife ueber alle Zellen des Bereiches 
    Next
  'Ende Schleife ueber alle Zeilen des Bereichs 
  Next
'Auszaehlen 
'Schleife ueber alle collectioneintraege 
For iColI = 1 To colNumb.Count
  'Wenn Zeilennumer = 1, dann 
    'Wenn Suchzahl nicht im Bereich ist, dann 
    If WorksheetFunction.CountIf(Range("D1:I" & .Rows.Count), colNumb(iColI)) = 0 Then
      cCount = cCount + 1
    'Alternativ zu Wenn Suchzahl nicht im Bereich ist, dann 
    Else
      'Schleife ueber alle Zeilen 
      For iCntR = .Rows.Count - 1 To 1 Step -1
        'Treffervariable auf false setzen 
        bolTref = False
        'Schleife ueber die Eintraege der Zeile in Spalten D:I 
        For iCntC = 4 To 9
          'Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Telle eingefaerbt ist, dann 
          If Cells(iCntR, iCntC).Value = colNumb(iColI) And Cells(iCntR, iCntC).Interior.ColorIndex <> xlNone Then
           'Treffervariable auf true setzen 
            bolTref = True
            'Schleife verlassen 
            Exit For
          'Ende Wenn der Zelleninhalt der gesuchten Zahl entspricht und die Telle eingefaerbt ist, dann 
          End If
        'Ende Schleife ueber die Eintraege der Zeile in Spalten D:I 
        Next
        'Wenn Treffervariable true, dann Schleife verlassen 
        If bolTref = True Then Exit For
      'Ende Schleife ueber alle Collectioneintraege 
      Next
      If bolTref = False Then
        cCount = cCount + 1
        Debug.Print colNumb(iColI) & vbTab & colRows(iColI) - 1 & vbTab & 1
      End If
    'Ende Wenn Suchzahl nicht im Bereich ist, dann 
    End If
'Ende Schleife ueber alle collectioneintraege 
Next
End With
'Counter an Funktionswert geben 
CountColored3 = cCount
End Function

Sub test()
MsgBox CountColored4(8)
End Sub

[Angelina]

hallo schauan,

bitte sende mir immer deine Muster-Datei mit dem VBCode Vorschlag.

Ich weiß sonst nicht - was hast du - was habe ich - was wo einbauen ... !


LG
Angelina

[schauan]

Hallo Angelina,

mach ich noch. Zuvor noch eine Frage zu der 12 und der 5.
Damit ich Zahlen nicht doppelt bewerte, werte ich ja nur die letzte 12 aus, also die in Zeile 5.

Zeile 5: 12 ist belegt, weil zuvor in Zeile 3 markiert
falsch
warum falsch?
Diese 12 in Zeile 3 wurde in Zeile 2 O:Z prognostiziert
in Abhängigkeit von dem AM1 Wert 5
Das bedeutet, das diese 12 aus Zeile 2 O:Z in
Zeile 2,3,4,5 kommen soll/wird (D:I)

Was ist mit Zeile 1? Dort könnte doch auch eine 12 stehen, wieso soll ich das nicht prüfen?

Was wäre, wenn die 12 vor Zeile 5 2x grau hinterlegt steht?

Zeile 2: 12 wird nicht bewertet, weil weiter oben schon
falsch

Wenn ich diese 12 anders bewerten würde als die in Zeile 5, wäre sie ja belegt. Wenn ich sie gleich bewerten muss, brauche ich sie auch nicht bewerten.

Wie gesagt, mir geht es hier erst mal um den Eintrag in Zeile 8.

[Angelina]

hallo schauan,

ich habe dir hier mal ein Demo Video hochgeladen.

Vielleicht versteht man es dann besser.

Endversion


LG
Angelina

[atilla]

Hallo Angelina,

unten eine Lösung auf xlph's Code aufbauend.
Ich nutze die Spalten M und N als Hilfsspalten. Wenn diese belegt sind, können es auch beliebig andere Spalten sein.

Wenn Du genau so vorgehst, wie im Video, geht es mit Erweiterung in xlph's Code.

Ersetze seinen Code mit folgendem und führe ihn einmal vor dem Löschen und dann nach jedem löschen aus. (von unten löschen)

Code:

Public Sub XLPH()

   Dim lngLetzteZeile As Long
   Dim lngSuchZeilenAnzahlMax As Long
   
   Dim rngSuchwert As Range
   
   Dim avntSuchwert() As Variant
   Dim iavntSuchwert1 As Long
   Dim iavntSuchwert2 As Long
   
   Dim rngDaten As Range
   
   Dim avntDaten() As Variant
   Dim iavntDaten1 As Long
   Dim iavntDaten2 As Long
   
   Dim vntSuchwert As Variant
   
   Dim avntErgebniswert() As Variant
   
   Dim blnFund As Boolean
   
   Dim rngFund As Range
   Dim rngDatenLastRow As Range
   
   With Tabelle1
       
       Intersect(.UsedRange, .Range("D:I")).Interior.ColorIndex = xlColorIndexNone
       Intersect(.UsedRange, .Range("O:Z")).Interior.Color = RGB(255, 204, 0)
       Intersect(.UsedRange, .Range("AA:AL")).ClearContents
       Intersect(.UsedRange, .Range("m:n")).ClearContents
       
       lngLetzteZeile = LetzteBeschriebeneZeile(.Range("D:AL"))
       If lngLetzteZeile = 0 Then Exit Sub
       
       lngSuchZeilenAnzahlMax = Val(.Range("AM1").Value)
       If lngSuchZeilenAnzahlMax = 0 Then Exit Sub
       
       Set rngDatenLastRow = Intersect(.Range("D:I"), .Rows(lngLetzteZeile))
       Set rngSuchwert = .Range("O1:Z" & lngLetzteZeile)
       avntSuchwert() = rngSuchwert.Value
               
       avntErgebniswert() = .Range("AA1:AL" & lngLetzteZeile).Value
       
       For iavntSuchwert1 = LBound(avntSuchwert, 1) To UBound(avntSuchwert, 1)
           
           Set rngDaten = .Range("D" & iavntSuchwert1).Resize(lngSuchZeilenAnzahlMax, 6)
         
           avntDaten() = rngDaten.Value
           
           For iavntSuchwert2 = LBound(avntSuchwert, 2) To UBound(avntSuchwert, 2)
               
               vntSuchwert = avntSuchwert(iavntSuchwert1, iavntSuchwert2)
               
               If Not IsEmpty(vntSuchwert) Then
               
                   For iavntDaten1 = LBound(avntDaten, 1) To UBound(avntDaten, 1)
                       For iavntDaten2 = LBound(avntDaten, 2) To UBound(avntDaten, 2)
                           If avntDaten(iavntDaten1, iavntDaten2) = vntSuchwert Then
                               avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = iavntDaten1
                               blnFund = True: Exit For
                           End If
                       Next
                       If blnFund Then Exit For
                   Next
                   
                   If blnFund Then
                       rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = RGB(192, 192, 192)
                       rngDaten.Cells(iavntDaten1, iavntDaten2).Interior.Color = RGB(192, 192, 192)
                       Cells(iavntDaten1 + iavntSuchwert1 - 1, 13) = Cells(iavntDaten1 + iavntSuchwert1 - 1, 13) + 1
                       blnFund = False
                   Else
                       Set rngFund = Range(rngDaten.Rows(1), rngDatenLastRow).Find(vntSuchwert, , xlValues, xlWhole)
                       If Not rngFund Is Nothing Then
                           If rngFund.Interior.Color <> RGB(192, 192, 192) Then
                               rngFund.Interior.Color = vbYellow
                               Cells(rngFund.Row, 13) = Cells(rngFund.Row, 13) + 1
                           End If
                           
                           rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
                       Else
                           Cells(iavntSuchwert2, 14) = Cells(iavntSuchwert2, 14) + 1
                       End If
                   End If
                   
               End If
               
           Next
           
           Set rngDaten = Nothing
           
       Next
       
       .Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
       .Cells(lngLetzteZeile, 40) = Application.Sum(.Range("N1:N" & lngLetzteZeile))
   End With
   
   Erase avntDaten
   Erase avntErgebniswert
   Erase avntSuchwert
   
   Set rngDatenLastRow = Nothing
   Set rngSuchwert = Nothing
   
End Sub

Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
   On Error Resume Next
   LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function

Die Spalte AN muss zu Beginn einmal manuell gelöscht werden.


Ich sehe gerade, die Spalte M ist nicht nötig, es reicht Spalte N als Hilfsspalte, mit folgendem Code:

Code:

Public Sub XLPH()

   Dim lngLetzteZeile As Long
   Dim lngSuchZeilenAnzahlMax As Long
   
   Dim rngSuchwert As Range
   
   Dim avntSuchwert() As Variant
   Dim iavntSuchwert1 As Long
   Dim iavntSuchwert2 As Long
   
   Dim rngDaten As Range
   
   Dim avntDaten() As Variant
   Dim iavntDaten1 As Long
   Dim iavntDaten2 As Long
   
   Dim vntSuchwert As Variant
   
   Dim avntErgebniswert() As Variant
   
   Dim blnFund As Boolean
   
   Dim rngFund As Range
   Dim rngDatenLastRow As Range
   
   With Tabelle1
       
       Intersect(.UsedRange, .Range("D:I")).Interior.ColorIndex = xlColorIndexNone
       Intersect(.UsedRange, .Range("O:Z")).Interior.Color = RGB(255, 204, 0)
       Intersect(.UsedRange, .Range("AA:AL")).ClearContents
       Intersect(.UsedRange, .Range("m:n")).ClearContents
       
       lngLetzteZeile = LetzteBeschriebeneZeile(.Range("D:AL"))
       If lngLetzteZeile = 0 Then Exit Sub
       
       lngSuchZeilenAnzahlMax = Val(.Range("AM1").Value)
       If lngSuchZeilenAnzahlMax = 0 Then Exit Sub
       
       Set rngDatenLastRow = Intersect(.Range("D:I"), .Rows(lngLetzteZeile))
       Set rngSuchwert = .Range("O1:Z" & lngLetzteZeile)
       avntSuchwert() = rngSuchwert.Value
               
       avntErgebniswert() = .Range("AA1:AL" & lngLetzteZeile).Value
       
       For iavntSuchwert1 = LBound(avntSuchwert, 1) To UBound(avntSuchwert, 1)
           
           Set rngDaten = .Range("D" & iavntSuchwert1).Resize(lngSuchZeilenAnzahlMax, 6)
         
           avntDaten() = rngDaten.Value
           
           For iavntSuchwert2 = LBound(avntSuchwert, 2) To UBound(avntSuchwert, 2)
               
               vntSuchwert = avntSuchwert(iavntSuchwert1, iavntSuchwert2)
               
               If Not IsEmpty(vntSuchwert) Then
               
                   For iavntDaten1 = LBound(avntDaten, 1) To UBound(avntDaten, 1)
                       For iavntDaten2 = LBound(avntDaten, 2) To UBound(avntDaten, 2)
                           If avntDaten(iavntDaten1, iavntDaten2) = vntSuchwert Then
                               avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = iavntDaten1
                               blnFund = True: Exit For
                           End If
                       Next
                       If blnFund Then Exit For
                   Next
                   
                   If blnFund Then
                       rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = RGB(192, 192, 192)
                       rngDaten.Cells(iavntDaten1, iavntDaten2).Interior.Color = RGB(192, 192, 192)
                       blnFund = False
                   Else
                       Set rngFund = Range(rngDaten.Rows(1), rngDatenLastRow).Find(vntSuchwert, , xlValues, xlWhole)
                       If Not rngFund Is Nothing Then
                           If rngFund.Interior.Color <> RGB(192, 192, 192) Then
                               rngFund.Interior.Color = vbYellow
                           End If
                           
                           rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
                       Else
                           Cells(iavntSuchwert2, 14) = Cells(iavntSuchwert2, 14) + 1
                       End If
                   End If
               End If
           Next
           Set rngDaten = Nothing
       Next
       .Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
       .Cells(lngLetzteZeile, 40) = Application.Sum(.Range("N1:N" & lngLetzteZeile))
   End With
   
   Erase avntDaten
   Erase avntErgebniswert
   Erase avntSuchwert
   
   Set rngDatenLastRow = Nothing
   Set rngSuchwert = Nothing
   
End Sub

Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
   On Error Resume Next
   LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function

[atilla]

Hallo Angelina,

ohne Hilfsspalte :05: 

Code:

Option Explicit


Public Sub XLPH()
 Dim dblSum As Double
   Dim lngLetzteZeile As Long
   Dim lngSuchZeilenAnzahlMax As Long
   
   Dim rngSuchwert As Range
   
   Dim avntSuchwert() As Variant
   Dim iavntSuchwert1 As Long
   Dim iavntSuchwert2 As Long
   
   Dim rngDaten As Range
   
   Dim avntDaten() As Variant
   Dim iavntDaten1 As Long
   Dim iavntDaten2 As Long
   
   Dim vntSuchwert As Variant
   
   Dim avntErgebniswert() As Variant
   
   Dim blnFund As Boolean
   
   Dim rngFund As Range
   Dim rngDatenLastRow As Range
   
   With Tabelle1
       
       Intersect(.UsedRange, .Range("D:I")).Interior.ColorIndex = xlColorIndexNone
       Intersect(.UsedRange, .Range("O:Z")).Interior.Color = RGB(255, 204, 0)
       Intersect(.UsedRange, .Range("AA:AL")).ClearContents
       Intersect(.UsedRange, .Range("m:n")).ClearContents
       
       lngLetzteZeile = LetzteBeschriebeneZeile(.Range("D:AL"))
       If lngLetzteZeile = 0 Then Exit Sub
       
       lngSuchZeilenAnzahlMax = Val(.Range("AM1").Value)
       If lngSuchZeilenAnzahlMax = 0 Then Exit Sub
       
       Set rngDatenLastRow = Intersect(.Range("D:I"), .Rows(lngLetzteZeile))
       Set rngSuchwert = .Range("O1:Z" & lngLetzteZeile)
       avntSuchwert() = rngSuchwert.Value
               
       avntErgebniswert() = .Range("AA1:AL" & lngLetzteZeile).Value
       
       For iavntSuchwert1 = LBound(avntSuchwert, 1) To UBound(avntSuchwert, 1)
           
           Set rngDaten = .Range("D" & iavntSuchwert1).Resize(lngSuchZeilenAnzahlMax, 6)
         
           avntDaten() = rngDaten.Value
           
           For iavntSuchwert2 = LBound(avntSuchwert, 2) To UBound(avntSuchwert, 2)
               
               vntSuchwert = avntSuchwert(iavntSuchwert1, iavntSuchwert2)
               
               If Not IsEmpty(vntSuchwert) Then
               
                   For iavntDaten1 = LBound(avntDaten, 1) To UBound(avntDaten, 1)
                       For iavntDaten2 = LBound(avntDaten, 2) To UBound(avntDaten, 2)
                           If avntDaten(iavntDaten1, iavntDaten2) = vntSuchwert Then
                               avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = iavntDaten1
                               blnFund = True: Exit For
                           End If
                       Next
                       If blnFund Then Exit For
                   Next
                   
                   If blnFund Then
                       rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = RGB(192, 192, 192)
                       rngDaten.Cells(iavntDaten1, iavntDaten2).Interior.Color = RGB(192, 192, 192)
                       blnFund = False
                   Else
                       Set rngFund = Range(rngDaten.Rows(1), rngDatenLastRow).Find(vntSuchwert, , xlValues, xlWhole)
                       If Not rngFund Is Nothing Then
                           If rngFund.Interior.Color <> RGB(192, 192, 192) Then
                               rngFund.Interior.Color = vbYellow
                           End If
                           
                           rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
                       Else
                           dblSum = dblSum + 1
                       End If
                   End If
               End If
           Next
           Set rngDaten = Nothing
       Next
       .Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
       .Cells(lngLetzteZeile, 40) = dblSum
   End With
   
   Erase avntDaten
   Erase avntErgebniswert
   Erase avntSuchwert
   
   Set rngDatenLastRow = Nothing
   Set rngSuchwert = Nothing
   
End Sub

Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
   On Error Resume Next
   LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function

Zuerst Spalte AN löschen.
Dann vor dem Löschen von Zahlen einmal ausführen und danach nach jedem Löschen.

[Angelina]

hallo Atilla,

danke auch dir für deine Rückmeldung.

Zuerst Spalte AN löschen.

Dann vor dem Löschen von Zahlen einmal ausführen und danach nach jedem Löschen.

Das wollte ich automatisieren - eben das ich nicht immer von Hand löschen und ausführen muss.

Aber der Ablauf ist bereits super so :32:

LG
Angelina

[Angelina]

hallo Atilla,

zwei kleinere Fehler sind mir eben aufgefallen:

1.
Die Ausgabe in Spalte AN ... also der AN-Wert der darf nur unterschiedliche Zahlen zählen.
Beispiel:
Ist z.B. der AN-Wert = 2 , dann darf z.B. die Zahl 19 nicht doppelt gezählt werden ... nur unterschiedliche Zahlen
zwischen 1 bis 49.
Also
19
19
sind nicht = 2 sondern AN-Wert 1

2.
LetzteBeschriebeneZeile
Darf nur im Bereich D:I gesucht werden
weil ich in den Spalten A,B,C und J,K,L,M,N noch andere Werte stehen habe.
Im Bereich D:I darf die letzte Beschriebene auch nur gezählt werden, wenn diese >0 ist - also größer Null
Weil ich dort für alle kommenden Einträge diesen weiteren Verlauf nach unten mit 0 - Nullern bereits
vorgeschrieben habe.

LG
Angelina