Comment obtenir une série?

Bonjour,

Voici un code qui répond à votre problème.
Je vous adresse un classeur exemple
directement à votre bal pour plus de facilité.
D'avance merci pour les $$$ et bons rêves.

A bientôt.

PMO

'*************************************
Sub Serie3()
Dim A$
Dim R As Range
Dim Var
Dim T1()
Dim T2()
Dim i&
Dim j&
Dim k&
'---- Nom de la feuille sélectionnée ----
A$ = ActiveSheet.Name
'---- Si aucune donnée on sort ----
Set R = ActiveSheet.UsedRange
If R.Rows.Count = 1 _
And R.Columns.Count = 1 Then Exit Sub
'---- On monte les données dans un variant ----
Var = R
'---- Repérage des triplés ----
For i& = 1 To UBound(Var, 1)
For j& = 3 To UBound(Var, 2)
If Var(i&, j&) <> "" Then
If Var(i&, j&) = Var(i&, j& - 1) And _
Var(i&, j&) = Var(i&, j& - 2) Then
k& = k& + 1
ReDim Preserve T1(1 To k&)
If IsDate(Var(i&, j&)) Then _
Var(i&, j&) = CDate(Var(i&, j&))
T1(k&) = Var(i&, j&)
End If
End If
Next j&
Next i&
'---- Si aucun triplé on sort ----
If k& = 0 Then Exit Sub
'---- Affectation dans tableau bidimensionné ---
ReDim T2(1 To k&, 1 To 2)
For i& = 1 To k&
T2(i&, 1) = T1(i&)
Next i&
'---- Création de la feuille de résultats ----
Sheets.Add after:=Sheets(Sheets.Count)
'---- Inscription des données et tri ----
Set R = Range(Cells(1, 1), Cells(k&, 2))
R = T2
R.Sort Key1:=[a1], Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
'---- Calcul des totaux des triplés ----
j& = 1
For i& = 1 To k& + 1
If Range("a" & i& & "") = _
Range("a" & i& + 1 & "") Then
j& = j& + 1
Else
'°°° Inscription du nb de triplés °°°
Range("b" & i& & "") = j&
j& = 1
End If
Next i&
'--- Tri par nb de triplès ----
R.Sort Key1:=[b1], Order1:=xlDescending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
'---- Destruction des lignes superflues ----
Rows("" & [b1].End(xlDown) _
.Row + 1 & ":" & k& & "").Delete
'---- Lignes de titres ----
Rows("1:2").Insert
[a1] = "Séries de 3 de la feuille ''" & A$ & "''"
[b1] = "Nb de séries"
[a1].Interior.ColorIndex = 34
[b1].Interior.ColorIndex = 35
Range("a1:b1").Font.Bold = True
'---- Ajustement des colonnes ----
Columns.AutoFit
End Sub
'*************************************

-----Message d'origine-----
Bonjour à tous,

Voici une question à 100$...Que dis-je??? Une question à
1

000$ Pis encore, 1 000 000$ sûrement...

Est-ce possible d'obtenir la série DE 3 qui se répète le
plus souvent entre plusieurs lignes ou d'une série de
données?

Ex:

A1 B1 C1 D1 E1 F1 G1
01 02 01 02 01 02 03
01 01 01 01 02 06 04
03 03 03 02 01 01 01

La réponse ici serais:
01 01 01, car elle se répète à la deuxième ligne A1 à
C1,

B1 à D1 et à la troisième ligne E1 à G1.

Méchante bonne question hein?

Si quelqu'un à une idée où "un-je-ne-sais-quoi" pour
trouver une solution à ce léger problème
plutôt "Série"eux

qui m'ennuie beaucoup...mon appréciation serait très
grande et mon sommeil aussi s'annoncerait probablement
mieux.

Starwing












.

Salut Starwing,

Si au lieu des repérage des triplés, j'aimerais qu'excel
analyse toutes les possibilités des séquences de trois de
chacune des lignes et qu'il me sorte celle qui revient le
plus souvent, Serais-ce long à modifier le code que tu
m'as envoyé?
exemple:


Essaie ceci:

' +++++++++++++++
Option Explicit

Sub SerieNbDiff()

Dim CST As Worksheet, nCol As Integer
Dim NomFeuilleSrc As String, JSg As String, i As Long, Res As Variant
Dim SData As Range ' Source Data
Dim DestData As Range ' Destination Data
Dim D2Data As Range, C As Range

JSg = " & "" "" & "
NomFeuilleSrc = ActiveSheet.Name

Set SData = ActiveSheet.Range("A1").CurrentRegion ' à adapter
nCol = SData.Columns.Count

'---- Création de la feuille de résultats ----
Set CST = Sheets.Add(after:=Sheets(Sheets.Count))

With SData ' avec feuille Source
Set DestData = CST.Cells(1, 1).Resize(.Rows.Count, nCol - 2)
DestData.FormulaR1C1 = "=" & _
.Cells(1, 1).Address(0, 0, ReferenceStyle:=xlR1C1, external:=True) & JSg
& _
.Cells(1, 2).Address(0, 0, ReferenceStyle:=xlR1C1, external:=True) & JSg
& _
.Cells(1, 3).Address(0, 0, ReferenceStyle:=xlR1C1, external:=True)
End With

DestData.Value = DestData.Value ' Remplace formules par valeurs
i = 0
Set D2Data = CST.Columns(nCol - 1)
' met les valeurs avec le nombre de celles-ci dans D2Data
For Each C In DestData
Res = Application.Match(C, D2Data, 0)
If IsError(Res) Then
i = i + 1
D2Data.Cells(i, 1) = C
D2Data.Cells(i, 2) = 1
Else
D2Data.Cells(Res, 2) = D2Data.Cells(Res, 2) + 1
End If
Next C
With D2Data.Resize(, 2)
.Sort KEY1:=.Cells(1, 2), ORDER1:=xlDescending, _
KEY2:=.Cells(1, 1), ORDER2:=xlAscending
End With

DestData.EntireColumn.Delete shift:=xlToLeft

' ----- Formattage -----
CST.Rows("1:1").Insert
CST.Range("A1") = "Séries de 3 de la feuille ''" & NomFeuilleSrc & "''"
CST.Range("B1") = "Nb de séries"
CST.Range("A1").Interior.ColorIndex = 34
CST.Range("B1").Interior.ColorIndex = 35
CST.Range("A1:B1").Font.Bold = True
CST.Columns.AutoFit ' Ajustement des colonnes

' Nettoyage
Set D2Data = Nothing: Set DestData = Nothing
Set SData = Nothing: Set CST = Nothing

End Sub

Salutations,

Daniel M.

Bonjour Daniel,

C'est super cool,

Je vais l'essayer ce soir et je te redonne des nouvelles...

Merci BEAUCOUP!!!BEAUCOUP!!!

Starwing

-----Message d'origine-----
Salut Starwing,

Si au lieu des repérage des triplés, j'aimerais qu'excel
analyse toutes les possibilités des séquences de trois de
chacune des lignes et qu'il me sorte celle qui revient le
plus souvent, Serais-ce long à modifier le code que tu
m'as envoyé?
exemple:


Essaie ceci:

' +++++++++++++++
Option Explicit

Sub SerieNbDiff()

Dim CST As Worksheet, nCol As Integer
Dim NomFeuilleSrc As String, JSg As String, i As Long,
Res As Variant

Dim SData As Range ' Source Data
Dim DestData As Range ' Destination Data
Dim D2Data As Range, C As Range

JSg = " & "" "" & "
NomFeuilleSrc = ActiveSheet.Name

Set SData = ActiveSheet.Range("A1").CurrentRegion ' à
adapter

nCol = SData.Columns.Count

'---- Création de la feuille de résultats ----
Set CST = Sheets.Add(after:=Sheets(Sheets.Count))

With SData ' avec feuille Source
Set DestData = CST.Cells(1, 1).Resize(.Rows.Count,
nCol - 2)

DestData.FormulaR1C1 = "=" & _
.Cells(1, 1).Address(0, 0, ReferenceStyle:=xlR1C1,
external:=True) & JSg

& _
.Cells(1, 2).Address(0, 0, ReferenceStyle:=xlR1C1,
external:=True) & JSg

& _
.Cells(1, 3).Address(0, 0, ReferenceStyle:=xlR1C1,
external:=True)

End With

DestData.Value = DestData.Value ' Remplace formules
par valeurs

i = 0
Set D2Data = CST.Columns(nCol - 1)
' met les valeurs avec le nombre de celles-ci dans D2Data
For Each C In DestData
Res = Application.Match(C, D2Data, 0)
If IsError(Res) Then
i = i + 1
D2Data.Cells(i, 1) = C
D2Data.Cells(i, 2) = 1
Else
D2Data.Cells(Res, 2) = D2Data.Cells(Res, 2) + 1
End If
Next C
With D2Data.Resize(, 2)
.Sort KEY1:=.Cells(1, 2), ORDER1:=xlDescending, _
KEY2:=.Cells(1, 1), ORDER2:=xlAscending
End With

DestData.EntireColumn.Delete shift:=xlToLeft

' ----- Formattage -----
CST.Rows("1:1").Insert
CST.Range("A1") = "Séries de 3 de la feuille ''" &
NomFeuilleSrc & "''"

CST.Range("B1") = "Nb de séries"
CST.Range("A1").Interior.ColorIndex = 34
CST.Range("B1").Interior.ColorIndex = 35
CST.Range("A1:B1").Font.Bold = True
CST.Columns.AutoFit ' Ajustement des colonnes

' Nettoyage
Set D2Data = Nothing: Set DestData = Nothing
Set SData = Nothing: Set CST = Nothing

End Sub

Salutations,

Daniel M.

.