Ursprüngliche Zahlen finden?

[atilla]

Hallo Angelina,

jetzt testen:

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
  Dim firstAddress As String
  Dim boVar As Boolean
  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
          With rngB
            Set rngC = .Find(Cells(i, j), , xlValues, xlWhole)
            If Not rngC Is Nothing Then
              firstAddress = rngC.Address
              Do
                Set rngC = .FindNext(rngC)
                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), "")
                    Exit Do
                  End If
                End If
              Loop While rngC.Address <> firstAddress
            Else
              If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & Cells(i, j)
            End If
          End With
        End If
      Next j
    Next i
    If UBound(Split(strgSammlung, "#")) > 0 Then
      Cells(lngZZ + k - 1, 40) = UBound(Split(strgSammlung, "#"))
    Else
      Cells(lngZZ + k - 1, 40) = 0
    End If
    k = k + lngZZ + 1
  Next pp

'  Range(Cells(merkZ, 4), Cells(lngZd, 9)).Clear
'  Range(Cells(merkZ+1, 15), Cells(lngZd, 38)).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

[Angelina]

hallo atilla,

sorry ... stimmt nicht!

Bei
441 S  21.03.2015 muss 14 als AN Wert kommen - wenn der schon falsch ist
dann brauche ich die anderen nicht zu testen.

Sorry


LG
Angelina

[atilla]

Hallo Angelina,

ja leider.

Mit Instr und zahlen funktioniert nicht so wie ich möchte. Muss noch mal in mich gehen. :@

[Angelina]

hallo

kein Thema ... bin auch müde

GUTE NACHT


LG
Angelina

[atilla]

Hallo Angelina,


letzter Versuch:

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
 Dim firstAddress As String
 Dim boVar As Boolean
 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
 If pp = 3 Then Stop
   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
         With rngB
           Set rngC = .Find(Cells(i, j), , xlValues, xlWhole)
           If Not rngC Is Nothing Then
             firstAddress = rngC.Address
             Do
               Set rngC = .FindNext(rngC)
               If Not rngC Is Nothing Then
                 If rngC.Interior.ColorIndex = xlColorIndexNone Then
                   If InStr(1, strgSammlung, Format(Cells(i, j), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(rngC, "00")
                 Else
                   If InStr(strgSammlung, Cells(i, j)) Then strgSammlung = Replace(strgSammlung, "#" & Format(Cells(i, j), "00"), "")
                   Exit Do
                 End If
               End If
             Loop While rngC.Address <> firstAddress
           Else
             If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & Format(Cells(i, j), "00")
           End If
         End With
       End If
     Next j
   Next i
   If UBound(Split(strgSammlung, "#")) > 0 Then
     Cells(lngZZ + k - 1, 40) = UBound(Split(strgSammlung, "#"))
   Else
     Cells(lngZZ + k - 1, 40) = 0
   End If
   k = k + lngZZ
 Next pp

'  Range(Cells(merkZ, 4), Cells(lngZd, 9)).Clear
'  Range(Cells(merkZ+1, 15), Cells(lngZd, 38)).Clear
'  Columns("M").Clear
 Application.ScreenUpdating = True
End Sub

Ich erhalte mit dem Code die gleichen Ergebnisse wie Andre. Leider ist mein Code einiges schneller. :19: 

Und für 441 erhalten Andre und ich 11. Zeig mal welche 14 Zahlen das sein sollen.

[atilla]

Hallo Angelina,

nur zur Info:

Das sind bei mir für  441 die Zahlen, die nicht gefärbt sind:

13, 14, 26, 24, 44, 35, 30, 02, 04, 10, 32

Zusatz:
Ich erhalte doch nicht die gleichen Ergebnisse wie Andre!

[schauan]

Hallo Angelina,

hab heut` Nacht zwar nicht von Dir, aber von der 12 und der 5 geträumt :17: und nun ist der Groschen hoffentlich gefallen.
Also, im viel zitierten Beispiel bewerte ich farblich markierten 12er in D:I bis einschließlich Zeile 5 nicht. Würde eine farblich markierte 12 in D:I in Zeile 6 oder 7 stehen, würde ich sie als nicht offen bewerten.

Werd' ich heute Abend einarbeiten und mal sehn, ob dann alles passt

Eventuell geb ich mal als "Entwicklungshilfe" noch zu jeder Eintragung in AN die bewerteten Zahlen als Massagebox aus oder ich schreib die irgendwo weiter rechts auf das Blatt.
Im Moment werden die auch im VBA-Editor im Direktfenster ausgegeben, Zahl und gefundene Zeile. Könntest dort also nachschauen, was mein code alles gefunden hat. Lediglich die 19 steht, bezogen auf das "alte" Beispiel, nicht dort - also, als Regel die Zahl, die keine Farbe hat. Allerdings hab ich da keine Trennung zwischen dem Bereich für Zeile 8 und Zeile 3. Sind also einige Zahlen doppelt und keiner weiß, wieso - jedenfalls kaum bei größeren Bereichen. Für das Beispiel ist das ja noch überschaubar.

So, spätestens in einer halben Stunde muss ich aufstehen und zur Arbeit. Bis später,

[schauan]

Hallo Angelina,

eine Sache noch. Für den Farbvergleich der 19 hab ich im Moment noch einen "Hilfseintrag" in AO1. Dort hab ich einfach die Originalfarbe von O:Z drin und mein code vergleicht, ob ein Eintrag ab O1 eine andere Farbe hat als AO1. Das werde ich auch noch abändern und die Farbe aus der ersten freien Zelle ab O1 entnehmen.

[Angelina]

hallo atilla,


habe deinen VBCode aus Beitrag Gestern, 22:08
getestet. Zuvor habe in dem VBCode die Zeile rausgenommen
'If pp = 3 Then Stop

Leider ist das Ergebnis auch nicht 14 für die 441

Es sind die Zahlen:
13,14 von 430 offen
26 von 431 offen
24,44 von 433 offen
35 von 434 offen
30 von 435 offen
2 von 436
19 von 438
4,10,32 von 439 offen
15,39 von 440 offen

Diese 14 Zahlen sind offen, weil sie nicht innerhalb des AM1 Wertes Beispiel 5 sind !!!
Also 14 offene Zahlen - siehe hierzu auch Video von gestern aus Beitrag:
Gestern, 21:09  
atilla-21-03-2016

LG
Angelina

[Angelina]

hallo schauan,

tut mir echt leid, wenn das Projekt sooooooo :92: schlaflose Nächte :76: bereitet.

Mach nur langsam - mach dir keinen Stress !!!

Danke nochmals bisher


LG
Angelina