Ursprüngliche Zahlen finden?

[atilla]

Hallo Angelina,

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

dann bin ich erst mal raus. War ja klar, das Du es einem nicht einfach machen wirst. :22:
So viel Zeit habe ich leider nicht.

Aber Andre arbeitet, so wie ich es sehe, in diese Richtung und wird sicher eine Lösung liefern können.

[Angelina]

hallo Atilla,

trotzdem DANKE für alle Mühe :100: 


LG
Angelina

[atilla]

Hallo Angelina,

die Aufgabe hat mich doch gereizt.

Mit einer Hilfsspalte und zwei neuen Zeilen in xlph's Code und einem weiteren von mir entwickelten Code, habe ich, so glaube ich, eine Lösung.

Die Hilfsspalte ist im Code Spalte M, kann aber auch eine belibig andere sein.
Statt dem bisherigen Code von xlph nimmst Du folgenden:

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)
                      If Cells(iavntDaten1 + iavntSuchwert1 - 1, 13) < 3 Then 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
                              If Cells(rngFund.Row, 13) < 3 Then Cells(rngFund.Row, 13) = Cells(rngFund.Row, 13) + 1
                          End If
                         
                          rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
                      Else
                         
                      End If
                  End If
                 
              End If
          Next
         
          Set rngDaten = Nothing
         
      Next
     
      .Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
  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

Nach Ausführung des obigen Codes folgenden ausführen:

Code:

Sub zählen()
  Dim i As Long, j As Long, pp As Long, k As Long
  Dim lngZd As Long, lngZZ
  Dim merkZ As Long
  Dim anzahlDreier As Long
  Dim strgSammlung As String
  Dim rngB As Range, rngC As Range
  lngZd = LetzteBeschriebeneZeile(Range("D:I"))
 
  Columns("AN").ClearContents
  anzahlDreier = Application.CountIf(Columns("M"), 3)
  If anzahlDreier = 0 Then Exit Sub
  merkZ = Application.Match(3, Columns("M"), 0)
 
  k = 1
  Application.ScreenUpdating = False
  For pp = 1 To anzahlDreier
    lngZZ = Application.Match(3, Range(Cells(k, 13), Cells(lngZd, 13)), 0)
    Set rngB = Range("D1:I" & lngZZ + k - 2)
    For i = 1 To lngZZ + k - 1
      For j = 15 To 26
        If Cells(i, j) <> "" Then
          Set rngC = rngB.Find(Cells(i, j), , xlValues, xlWhole)
          If Not rngC Is Nothing Then
            If rngC.Interior.ColorIndex = xlColorIndexNone Then
              If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & rngC
            Else
              If InStr(strgSammlung, Cells(i, j)) Then strgSammlung = Replace(strgSammlung, Cells(i, j) & "#", "")
            End If
          Else
            If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & Cells(i, j)
          End If
        End If
      Next j
    Next i
    If UBound(Split(strgSammlung, "#")) > 0 Then Cells(lngZZ + k - 1, 40) = UBound(Split(strgSammlung, "#"))
    k = lngZZ + 1
  Next pp

  Range(Cells(merkZ, 4), Cells(lngZd, 9)).Clear
  Columns("M").Clear
  Application.ScreenUpdating = True
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

[schauan]

Hallo Angelina,

anbei hab ich hoffentlich die fertige Version.
Ich habe das Makro schon dem Button AN Zählen zugewiesen.

Zumindest der code zum Löschen der Daten im Bereich D:I ist auch drin, ich weiß nach Deinem Video nur nicht, wieso ich löschen soll, wo Du doch am Ende den Ausgangszustand wiederherstellst. Zur Bewertung ist das Löschen jedenfalls nicht nötig, es werden nur die jeweils bis zur Zeile mit den 3 zugehörigen Bereiche oberhalb ausgezählt.

Die Frage nach der 12 und der 5 in AM ist mit dem Video allerdings nicht beantwortet. In der Zählung für AN 8 ist sie nun draußen bzw. wird automatisch als offen bewertet, egal, was da an zwölfen im Bereich D:I oder auch steht und gefärbt ist oder nicht. Ebenso die 16 aus Zeile 5. Würde z.B. in O 6 oder später noch eine 12 stehen, würde es wieder anders aussehen. Aber vielleicht kann so eine Konstellation auch nicht passieren. Ich tue ja die Zahlen von hinten - also von unten - aufsammeln und auch nur einfach und nicht doppelt.

Bei der Zählung für AN 3 wird die 12 hingegen berücksichtigt, da keine gefärbte in D1:I2 vorhanden ist, ist sie aber auch offen.

Schaue einfach mal mit unterschiedlichen Daten, ob die Ergebnisse passen.

[Angelina]

hallo Atilla,


vielen lieben Dank ... hat mich sehr gefreut, das du es versucht hast.

In der Anlage eine aktuelle Datei mit deinem VBCode.

Geht leider nicht - bei mir! - aber schaue mal selbst ... wenn du mal Zeit bekommst.

Ich habe die Zeilen mal rot markiert, die mind. 3 farbliche haben - dann sieht man es besser
auf den ersten Blick.


LG
Angelina

[schauan]

Hallo Angelina,

mit meinem sollte es hoffentlich klappen.
Ich schaue mir es morgen weiter an, mache jetzt wieder Feierabend

[Angelina]

hallo schauan,


danke auch dir nochmals für alle Zeit und Mühe

leider nicht ...

ich habe dir auch mal eine Datei angehängt


z.B. bei
441 S 21.03.2015
sollte AN Wert 14 rauskommen - bei dir 11

aber schaue selbst!


LG
Angelina

[atilla]

Hallo Angelina,

dann teste noch einmal mit folgendem Code:

Code:

Sub zählen()
 Dim i As Long, j As Long, pp As Long, k As Long
 Dim lngZd As Long, lngZZ
 Dim merkZ As Long
 Dim anzahlDreier As Long
 Dim strgSammlung As String
 Dim rngB As Range, rngC As Range
 lngZd = LetzteBeschriebeneZeile(Range("D:I"))

 Columns("AN").ClearContents
 anzahlDreier = Application.CountIf(Columns("M"), 3)
 If anzahlDreier = 0 Then Exit Sub
 merkZ = Application.Match(3, Columns("M"), 0)

 k = 1
 Application.ScreenUpdating = False
 For pp = 1 To anzahlDreier - 1
   lngZZ = Application.Match(3, Range(Cells(k, 13), Cells(lngZd, 13)), 0)
   Set rngB = Range("D1:I" & lngZZ + k - 2)
   For i = 1 To lngZZ + k - 1
     For j = 15 To 26
       If Cells(i, j) <> "" Then
         Set rngC = rngB.Find(Cells(i, j), , xlValues, xlWhole)
         If Not rngC Is Nothing Then
           If rngC.Interior.ColorIndex = xlColorIndexNone Then
             If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & rngC
           Else
             If InStr(strgSammlung, Cells(i, j)) Then strgSammlung = Replace(strgSammlung, "#" & Cells(i, j), "")
           End If
         Else
           If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & Cells(i, j)
         End If
       End If
     Next j
   Next i
   If UBound(Split(strgSammlung, "#")) > 0 Then Cells(lngZZ + k - 1, 40) = UBound(Split(strgSammlung, "#"))
   k = k + lngZZ + 1
 Next pp

'  Range(Cells(merkZ, 4), Cells(lngZd, 9)).Clear
'  Columns("M").Clear
 Application.ScreenUpdating = True
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

Das Löschen habe ich auskommentiert.

[atilla]

Hallo Angelina,

brauchst nicht testen, muss noch nachbessern.

[Angelina]

hallo atilla,

oh Gott ... was habe ich da nur angefangen  

Ich mache euch noch wahnsinnig :16:  sorry


hier ein aktuelles Video von deiner Berechnung

atilla-21-03-2016

LG
Angelina