Serie herausfinden

[shacalaca]

Hallo Leute :)

ich bin langsam am verzweifeln... Ich versuche von Excel automatisiert Serien erkennen zu lassen... Habe das Ganze jetzt mal händisch gemacht, aber würde das gerne für viele weitere 10000ende von Zeilen machen :D

Hier mal zur Verdeutlichung:

   



Die Serien der 0en bzw 1en soll gezählt werden. Es bezieht sich also auf Spalte J, ich will wissen wie oft hintereinander eine 1 oder eine 0 gestanden hat.

Falls mir da jemand helfen kann, wäre ich ihm zu sehr dankbar :*

[WillWissen]

Hi,

hier mal ein Vorschlag mit einer Hilfsspalte, die du einfach ausblendest:

Tabelle4

	A	B	C
1	1	1	1
2	0	2	3
3	0	2
4	0	2
5	1	3	1
6	0	4	3
7	0	4
8	0	4
9	1	5	2
10	1	5
11	0	6	2
12	0	6
13	1	7	3
14	1	7
15	1	7

Formeln der Tabelle

Zelle Formel C1 =ZÄHLENWENN($B$1:$B$15;B1) B2 =WENN(A1=A2;B1;B1+1) C2 =WENN(B2<>B1;ZÄHLENWENN($B$1:$B$15;B2);"")

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8

[shacalaca]

Hi,

hier mal ein Vorschlag mit einer Hilfsspalte, die du einfach ausblendest:

Tabelle4

	A	B	C
1	1	1	1
2	0	2	3
3	0	2
4	0	2
5	1	3	1
6	0	4	3
7	0	4
8	0	4
9	1	5	2
10	1	5
11	0	6	2
12	0	6
13	1	7	3
14	1	7
15	1	7

Formeln der Tabelle

Zelle Formel C1 =ZÄHLENWENN($B$1:$B$15;B1) B2 =WENN(A1=A2;B1;B1+1) C2 =WENN(B2<>B1;ZÄHLENWENN($B$1:$B$15;B2);"")

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8


gar keine so schlechte idee   werde ich morgen mal ausprobieren. vielen dank :)   

[lupo1]

80.000 ZÄHLENWENN x 40.000 Auswertungszellen = 3,2 Mrd Rechenvorgänge! => Probiere es besser nicht aus!

A2: Deine Daten 0 und 1
B2: =(A1=A2)*B1+1
C2: =B2*(B2>=B3) mit Format 0;;

Die Anzahlen der jew. Gruppe stehen beim letzten Auftreten, nicht beim ersten.

[atilla]

Hallo zusammen,

bei so vielen Daten, könnte man auch VBA einsetzen.

Zum Beispiel würde der folgende Code die Serien beim ersten Auftreten listen:

Code:

Sub serien()

 Dim i As Long, j As Long
 Dim lngZ As Long

 Dim arr As Variant
 Dim varK
 Dim D1 As Object
 Set D1 = CreateObject("Scripting.Dictionary")

 Application.ScreenUpdating = False
 With Worksheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   arr = .Range("A1:A" & lngZ)
   
   For i = 2 To UBound(arr)
     If arr(i, 1) <> arr(i - 1, 1) Then
       D1(j + 1) = D1(j + 1) + 1
       j = j + 1
     Else
        D1(j) = D1(j) + 1
     End If
   Next i
   
   .Range("B2:B" & lngZ).ClearContents
   arr = .Range("B1:B" & lngZ)
   j = 1
   For Each varK In D1.keys
     arr(j, 1) = D1(varK)
     j = D1(varK) + j
   Next
   .Range("B2:B2").Resize(j) = arr
 End With
 Application.ScreenUpdating = True

End Sub

Und folgender beim letzten Auftreten:

Code:

Sub serien()

 Dim i As Long, j As Long
 Dim lngZ As Long

 Dim arr As Variant
 Dim varK
 Dim D1 As Object
 Set D1 = CreateObject("Scripting.Dictionary")

 Application.ScreenUpdating = False
 With Worksheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   arr = .Range("A1:A" & lngZ)
   
   For i = 2 To UBound(arr)
     If arr(i, 1) <> arr(i - 1, 1) Then
       D1(j + 1) = D1(j + 1) + 1
       j = j + 1
     Else
        D1(j) = D1(j) + 1
     End If
   Next i
   
   .Range("B1:B" & lngZ).ClearContents
   arr = .Range("B1:B" & lngZ)
   j = 1
   For Each varK In D1.keys
   j = D1(varK) + j
     arr(j, 1) = D1(varK)
     
   Next
   .Range("B1:B2").Resize(j) = arr
 End With
 Application.ScreenUpdating = True

End Sub

[Ego]

Hallo atilla,

man muss das mit dem Scripting.Dictionary auch nicht übertreiben.

In diesem Fall, in dem die Position der Ausgabe bekannt ist, verdoppelt die Nutzung des Scripting.Dictionaries die Rechenzeit.
(Auf meinem Rechner bei 100.000 Zeilen von 0,17 auf 0,37 Sekunden ).

Hier ohne Scripting.Dictionary

Code:

Private Sub serien()

 Dim i As Long, j As Long
 Dim dblStart As Double
 Dim lngZ As Long

 Dim arr As Variant
 Dim arrz As Variant
 Dim varK

 Application.ScreenUpdating = False
 dblStart = Timer
 With Worksheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   arr = .Range("A1:A" & lngZ)
   .Range("B1:B" & lngZ).ClearContents
   arrz = .Range("B1:B" & lngZ)
   j = 1
   arrz(j, 1) = 1
   For i = 2 To UBound(arr)
     If arr(i, 1) <> arr(i - 1, 1) Then
        j = i
        arrz(j, 1) = 1
     Else
        arrz(j, 1) = arrz(j, 1) + 1
     End If
   Next i   
   .Range("B1:B" & lngZ) = arrz
 End With
 MsgBox Timer - dblStart
 Application.ScreenUpdating = True
End Sub

ps (Bei 1.000.000 Zeilen von 1,6 auf 17 Sekunden )

[atilla]

Gutem Morgen Helmut,

schöne Lösung.
Es sieht so aus, als ob Du um die Zeit ausgeschlafener bist als ich.

Aber das mit Bereiche leer in ein Array einlesen und wieder zurückschreiben ist schon eine tolle Sache, oder?

[shacalaca]

vielen dank für die antworten :)

ja sind einige daten ;;) aber in der regel werden nie mehr als 5000 auf einmal bearbeitet.

[BoskoBiati]

Hi,

da würde ich das mit Formeln machen:

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C
2	0	1	2
3	1	0	1
4	1	2	2
5	0	3	1
6	1	0	3
7	1	4	1
8	0	5	1
9	1	0	1
10	1	0	2
11	1	6	1

Zelle	Formel
B2	=(A3<>A2)*(MAX(B$1:B1)+1)
C2	=WENNFEHLER(VERGLEICH(ZEILE(A2);B:B;0);ANZAHL(A:A))-VERGLEICH(ZEILE(A1);B:B;0)

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg