Ursprüngliche Zahlen finden?

[Angelina]

hallo snb,

aha ... jetzt kommen wir der Sache schon näher.

Dein Vorschlag hat also nichts mir der Erweiterung zu tun, sondern mit dem ursprünglichen VBCode.

Die Anzahl der Zahlen kommt aber in Spalte M
und die eigentlichen Zahlen in Spalte N

Dann fehlt die rote Markierung in Spalte A,B,C usw.

Aber egal ... tolle Arbeit ... Danke dafür ... ich bleibe aber bei der Variante schauan und/oder atilla
Die Geschwindigkeit reicht aus.

Aber wirklich ... tolle Arbeit.

Ich hänge nun an der Erweiterung ... das ist jetzt mal viel wichtiger!

Danke dir

LG
Angelina

[snb]

Die Farbemarkierungen sind nicht. wichtig.

Meiner Vorschlag läuft viele Male geschwindiger als die andere Code.

[atilla]

Hallo Angelina,

ersetze die Prozedur Sub zählen_Ati() wie folgt

Wichtig: es muss in der Datei noch ein Tabellenblatt mit der Bezeichnung "Tabelle2" vorhanden sein.

Code:

Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public arr()
Dim lngMax As Long

Sub zählen_Ati()
 Dim lngLetzteZeile As Long, pp As Long, n As Long, lngP As Long, x, zz
 Dim i As Long, j As Long
 Dim strgSammlung As String
 Dim vantQ As Variant

 Dim arrZ()
 
 Dim loStartTime As Long
 loStartTime = GetTickCount
 

 Application.ScreenUpdating = False
 zählen
 lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
 vantQ = Range("O1:AL" & lngLetzteZeile)
 Columns("AN:AO").ClearContents
 Columns("N").Font.ColorIndex = xlAutomatic
 For pp = 0 To lngMax - 1
 For i = 1 To arr(pp) + 1
   For j = 13 To 24
     If vantQ(i, j) < 6 Then
       If vantQ(i, j) - 1 + i > arr(pp) Or i = arr(pp) + 1 Then
         If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
       End If
     Else
       If vantQ(i, j) + i - 1 > arr(pp) Then
         If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
       End If
     End If
   Next j
 Next i
   If UBound(Split(strgSammlung, "#")) > 0 Then
     Cells(arr(pp) + 1, 40) = UBound(Split(strgSammlung, "#"))
     Cells(arr(pp) + 1, 14) = Replace(Join(Split(strgSammlung, "#"), ", "), ", ", "", 1, 1)
     For n = 1 To UBound(Split(strgSammlung, "#"))
       zz = Application.Max(zz, n)
       ReDim Preserve arrZ(lngMax - 1, 0 To zz)
       x = Application.Match(CDbl(Split(strgSammlung, "#")(n)), Range(Cells(arr(pp) + 1, 4), Cells(arr(pp) + 1, 9)), 0)
       If IsNumeric(x) Then
         lngP = n * 3 + n - 3
         Cells(arr(pp) + 1, 14).Characters(Start:=lngP, Length:=2).Font.ColorIndex = 3
         arrZ(pp, n - 1) = n
       Else
         arrZ(pp, n - 1) = ""
       End If
     Next n
   Else
     Cells(arr(pp) + 1, 40) = 0
   End If
   strgSammlung = ""
 Next pp

 Columns("AQ:AR").ClearContents
 With Sheets("Tabelle2")
   .Cells.Clear
   .Cells(2, 1).Resize(pp, zz) = (arrZ)
   .Cells(1, 1).Resize(1, zz).FormulaLocal = "=Anzahl(A2:" & Cells(pp + 1, 1).Address(0, 0) & ")"
   .Cells(1, 1).Resize(pp + 1, zz).Sort key1:=.Cells(1, 1), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
   i = 1
   For n = 1 To lngMax
     If .Cells(1, 1) > 0 Then
       Cells(i, 43) = .Cells(1, 1)
       Cells(i, 44) = Application.Max(.Cells(2, 1).Resize(pp + 1, 1))
       .Cells(2, 1).Resize(pp + 1, 1).SpecialCells(xlCellTypeConstants).EntireRow.Delete
       .Cells(1, 1).Resize(pp + 1, zz).Sort key1:=.Cells(1, 1), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
       i = i + 1
     End If
   Next n
 End With
 
 Erase arr
 Erase arrZ
 Application.ScreenUpdating = True
 MsgBox "Laufzeit " & _
 (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
   vbInformation, "Application.Wait Soll: 3 Sekunden"
   
End Sub

@snb

schöne Lösung und sehr interessante Herangehensweise.

Du musst aber noch ein paar wenige Zeilen Code ergänzen.
1. sollen keine Doppelten Zahlen eingelesen werden
2. Spalten A:C sollen rot markiert werden bei entsprechender Bedingung
3. Spalte AM soll die Anzahl stehen
4. Spalte AN soll die Anzahl der gefärbten Zellen in D:I in der Zeile stehen

Und ansonsten, sind wir schon in Köln angelangt, während Du noch den Weg nach Eindhoven beschreibst.
Und ob mehr Code oder weniger spielt eher keine Rolle, wichtig ist das Ziel sicher zu erreichen.

Wenn Du die Färbungen noch mit rein nimmst, dann bist Du auch nicht mehr auf der Autobahn.

Aber wie schon gesagt, ich schaue mir Deine Codes sehr interessiert an und versuche auch daraus zu lernen.
Mich beeindrucken Deine Ideen zur Lösungsfindung. Wenn  Du manchmal auch noch ein Paar Worte dazu schreiben würdest,
wäre es für viele anderen auch einfacher nachzuvollziehen oder zu verstehen.

[Angelina]

guten morgen atilla,

danke nochmals für deinen Einsatz!


Ich weiß nicht, warum der VBCode bei mir hier hängen bleibt

Code:

Application.ScreenUpdating = False
 zählen

zählen

LG
Angelina

[atilla]

Hallo Angelina,

etwas mitdenken bitte.

Du hast einmal die Prozedur zählen_Ati und einmal  die Funktion zählen im gleichen Modul.

Und ich habe nur für die Prozedur einen Code eingestellt.

[Angelina]

hallo atilla,

etwas mitdenken bitte.

:30:

sorry!


:18:  perfekt so ... Tip Top ... genau so ... :98:


Dürfte ich dich jetzt noch um eine ... wirklich um eine kleine Sache bitten?
Ja ... ich weiß was du denkst :22:

Ich müsste nun nur noch sehen, wann welche Position das letzte mal in der Spalte N
rot vorgekommen ist.

Ich habe dazu meine Mappe nochmals angehängt.

Spalte AQ = Anzahl
Spalte AR = Position

Spalte AS = Wie lange nicht belegt

Ausgehend von der letzten beschriebene
Zeile von D:I

In der BeispielMappe in der Anlage
ist die letzte beschriebene Zeile von
D:I die Zeile 117 vom 13.02.2016

Die Zahl 20 in der Spalte N ist die Position 1
somit hätte die Spalte AS neben 17/1 die 0

Die Position 4 kam das letzte mal in der Zeile 110
somit hätte die Spalte AS neben 15/4 die -8

Die Position 6 kam das letzte mal in der Zeile 100
somit hätte die Spalte AS neben 13/6 die -18

immer ausgehend/rückwirkend vom der letzten beschriebenen
Zeile in D:I


AQ    AR    AS
17    1     0
15    4    -8
13    6    -18
10    9    usw.
7    5    usw.
6    7    
5    8    
4    3    
4    10    
2    2    
1    11    

Dann ist wirklich gut ...


LG
Angelina

[atilla]

Hallo Angelina,

da hast Du aber Glück, dass ich es mit kleinen Anpassungen am bestehenden Code lösen konnte.

Wie gehabt diesen Teil ersetzen:

Code:

Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public arr()
Dim lngMax As Long

Sub zählen_Ati()
Dim lngLetzteZeile As Long, pp As Long, n As Long, lngP As Long, x, zz
Dim i As Long, j As Long
Dim strgSammlung As String
Dim vantQ As Variant
 Dim lngZ As Long
Dim arrZ()

Dim loStartTime As Long
loStartTime = GetTickCount


Application.ScreenUpdating = False
zählen
lngZ = Application.CountIf(Range("D:D"), ">0")
lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
vantQ = Range("O1:AL" & lngLetzteZeile)
Columns("AN").ClearContents
Columns("N").Font.ColorIndex = xlAutomatic
For pp = 0 To lngMax - 1
For i = 1 To arr(pp) + 1
  For j = 13 To 24
    If vantQ(i, j) < 6 Then
      If vantQ(i, j) - 1 + i > arr(pp) Or i = arr(pp) + 1 Then
        If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
      End If
    Else
      If vantQ(i, j) + i - 1 > arr(pp) Then
        If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
      End If
    End If
  Next j
Next i
  If UBound(Split(strgSammlung, "#")) > 0 Then
    Cells(arr(pp) + 1, 40) = UBound(Split(strgSammlung, "#"))
    Cells(arr(pp) + 1, 14) = Replace(Join(Split(strgSammlung, "#"), ", "), ", ", "", 1, 1)
    For n = 1 To UBound(Split(strgSammlung, "#"))
      zz = Application.Max(zz, n)
      ReDim Preserve arrZ(lngMax - 1, 0 To zz + 1)
      x = Application.Match(CDbl(Split(strgSammlung, "#")(n)), Range(Cells(arr(pp) + 1, 4), Cells(arr(pp) + 1, 9)), 0)
      If IsNumeric(x) Then
        lngP = n * 3 + n - 3
        Cells(arr(pp) + 1, 14).Characters(Start:=lngP, Length:=2).Font.ColorIndex = 3
        arrZ(pp, 0) = arr(pp) + 1
        arrZ(pp, n) = n
      Else
        arrZ(pp, n) = ""
      End If
    Next n
  Else
    Cells(arr(pp) + 1, 40) = 0
  End If
  strgSammlung = ""
Next pp

Columns("AQ:AS").ClearContents
With Sheets("Tabelle2")
  .Cells.Clear
  .Cells(2, 1).Resize(pp, zz) = (arrZ)
  .Cells(1, 2).Resize(1, zz).FormulaLocal = "=Anzahl(B2:" & Cells(pp + 1, 2).Address(0, 0) & ")"
  .Cells(1, 1).Resize(pp + 1, 1).Value = .Cells(1, 1).Resize(pp + 1, 1).Value
  .Cells(1, 2).Resize(pp + 1, zz).Sort key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
  i = 1
  For n = 1 To lngMax
    If .Cells(1, 2) > 0 Then
      Tabelle1.Cells(i, 43) = .Cells(1, 2)
      Tabelle1.Cells(i, 44) = Application.Max(.Cells(2, 2).Resize(pp + 1, 1))
      Tabelle1.Cells(i, 43) = .Cells(1, 2)
      Tabelle1.Cells(i, 45) = .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 1) - lngZ
      .Cells(1, 2).Resize(pp + 1, 1).SpecialCells(xlCellTypeConstants).EntireRow.Delete
      .Cells(1, 2).Resize(pp + 1, zz).Sort key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
      i = i + 1
    End If
  Next n
End With

Erase arr
Erase arrZ
Application.ScreenUpdating = True
MsgBox "Laufzeit " & _
(GetTickCount - loStartTime) / 1000 & " Sekunden.", _
  vbInformation, "Application.Wait Soll: 3 Sekunden"
 
End Sub

[Angelina]

hallo atilla,

danke das du diesen Schritt noch mit mir gegangen bist - DANKE !!!


Du hast das Prinzip richtig verstanden :19: 

Leider hast sich bei der Zählung ein kleiner Fehlerteufel versteckt :21: 

Warum ?  

In der Musterdatei "Zuletzt.xls"
kommt der neue VBCode auf dieses Ergebnis:

PHP-Code:

17    1     0
15    4    -7
13    6    -17
10    9    -14
7    5    -10
6    7    -18  Zeile 104 ist also -13
5    8    -20  Zeile 102 ist also -15
4    3    -6
4    10    -21  Zeile 98 ist also -19
2    2    -37  Zeile 104 ist also -13
1    11    -40 


Ich vermute der Zählfehler kommt aus dem Bereich sobald mehrere Zahlen in einer Reihe rot / zum Zählen /
in Betracht kommen - denke ich mal !

Dort wo ich Zeile ... ist also .... geschrieben habe - besteht ein Zählfehler.
Also derzeit 4 x Zählfehler.

LG
Angelina

[atilla]

Hallo Angelina,

das ist blöd,  :22:

Das ist kein Fehler, sondern kommt daher, dass ich beim ersten Treffer der Position die Zeile auslese.
Der Code müsste die Zeilen unten nach oben abarbeiten.


Dann muss wieder mal nachsitzen :@

[atilla]

Hallo Angelina,

wie gehabt:

Code:

Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public arr()
Dim lngMax As Long

Sub zählen_Ati()
Dim lngLetzteZeile As Long, pp As Long, n As Long, lngP As Long, x, zz
Dim i As Long, j As Long
Dim strgSammlung As String
Dim vantQ As Variant
 Dim lngZ As Long
Dim arrZ()
Dim vntF
Dim strgZ As String
Dim loStartTime As Long
loStartTime = GetTickCount
Tabelle1.Select

Application.ScreenUpdating = False
zählen
lngZ = Application.CountIf(Range("D:D"), ">0")
lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
vantQ = Range("O1:AL" & lngLetzteZeile)
Columns("AN").ClearContents
Columns("N").Font.ColorIndex = xlAutomatic
For pp = 0 To lngMax - 1
For i = 1 To arr(pp) + 1
  For j = 13 To 24
    If vantQ(i, j) < 6 Then
      If vantQ(i, j) - 1 + i > arr(pp) Or i = arr(pp) + 1 Then
        If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
      End If
    Else
      If vantQ(i, j) + i - 1 > arr(pp) Then
        If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
      End If
    End If
  Next j
Next i
  If UBound(Split(strgSammlung, "#")) > 0 Then
    Cells(arr(pp) + 1, 40) = UBound(Split(strgSammlung, "#"))
    Cells(arr(pp) + 1, 14) = Replace(Join(Split(strgSammlung, "#"), ", "), ", ", "", 1, 1)
    For n = 1 To UBound(Split(strgSammlung, "#"))
      zz = Application.Max(zz, n)
      ReDim Preserve arrZ(lngMax - 1, 0 To zz + 1)
      x = Application.Match(CDbl(Split(strgSammlung, "#")(n)), Range(Cells(arr(pp) + 1, 4), Cells(arr(pp) + 1, 9)), 0)
      If IsNumeric(x) Then
        lngP = n * 3 + n - 3
        Cells(arr(pp) + 1, 14).Characters(Start:=lngP, Length:=2).Font.ColorIndex = 3
        arrZ(pp, 0) = arr(pp) + 1
        arrZ(pp, n) = n
      Else
        arrZ(pp, n) = ""
      End If
    Next n
  Else
    Cells(arr(pp) + 1, 40) = 0
  End If
  strgSammlung = ""
  strgZ = ""
Next pp

Columns("AQ:AS").ClearContents
With Sheets("Tabelle2")
  .Cells.Clear
  .Cells(2, 1).Resize(pp, zz) = (arrZ)
  .Cells(1, 2).Resize(1, zz).FormulaLocal = "=Anzahl(B2:" & Cells(pp + 1, 2).Address(0, 0) & ")"
  .Cells(pp + 2, 2).Resize(1, zz).FormulaLocal = "=Max(B2:" & Cells(pp + 1, 2).Address(0, 0) & ")"
  .Cells(pp + 3, 2).Resize(1, zz).FormulaLocal = "=Vergleich(0;B1:" & .Cells(pp + 1, 2).Address(0, 0) & ";-1)"
  vntF = .Cells(1, 1).Resize(pp + 3, zz + 1)
  .Cells(1, 2).Resize(pp + 1, zz).Sort key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
  i = 1
  For n = 1 To lngMax
    If .Cells(1, 2) > 0 Then
      Cells(i, 43) = .Cells(1, 2)
      Cells(i, 44) = Application.Max(.Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)))
      Cells(i, 43) = .Cells(1, 2)
      .Cells(1, 2).Resize(pp + 1, 1).SpecialCells(xlCellTypeConstants).EntireRow.Delete
      .Cells(1, 2).Resize(pp + 1, zz).Sort key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
      i = i + 1
    End If
  Next n
  .Cells(1, 1).Resize(pp + 3, zz + 1) = vntF
End With

For i = 1 To Application.Count(Columns("AR"))
 With Sheets("Tabelle2")
   Cells(i, 45) = .Cells(.Cells(pp + 3, Application.Match(Cells(i, 44), .Cells(pp + 2, 2).Resize(1, zz), 0) + 1), 1) - lngZ
 End With
Next i

Erase arr
Erase arrZ
Application.ScreenUpdating = True
MsgBox "Laufzeit " & _
(GetTickCount - loStartTime) / 1000 & " Sekunden.", _
  vbInformation, "Application.Wait Soll: 3 Sekunden"
 
End Sub