Option Explicit
Sub AALaunchd()
Call SeqAAd(1, 3, 4, 2)
End Sub
Sub SeqAAd(x&, y&, r&, c&)
'entrées : coordonnées 1 ere cellule upstream, coordonnées 1ere cellule écriture séquences
Dim Tda(), Tdb(), Tdc(), Tdd(), RwT&, Cpt&(1 To 5), i&, j&, m&, n&, k%, Fl&, Dl&, ps&, a%, Rd%, Cc%, b As Boolean, oT As Worksheet, oS As Worksheet
Set oT = Worksheets("Tables"): Set oS = Worksheets("Sequences")
RwT = oT.Cells(y, x).End(xlDown).Row: If RwT = Rows.Count Then Exit Sub
'individus
For i = y To RwT
For j = 1 To 2
If i * j = y Then
Cpt(1) = 1: ReDim Tda(1 To 1): Tda(1) = oT.Cells(i, j)
Else
Cpt(1) = Cpt(1) + 1: ReDim Preserve Tda(1 To Cpt(1)): Tda(Cpt(1)) = oT.Cells(i, j)
End If
For k = 1 To Cpt(1) - 1
If Tda(Cpt(1)) = Tda(k) Then
Cpt(1) = Cpt(1) - 1: ReDim Preserve Tda(1 To Cpt(1)): Exit For
End If
Next k
Next j
Next i
'départs
For i = 1 To Cpt(1)
If WorksheetFunction.CountIf(oT.Range(oT.Cells(y, 2), oT.Cells(RwT, 2)), Tda(i)) = 0 Then
Cpt(2) = Cpt(2) + 1
If Cpt(2) = 1 Then
ReDim Tdb(1 To 1)
Else
ReDim Preserve Tdb(1 To Cpt(2))
End If
Tdb(Cpt(2)) = Tda(i)
End If
Next i
If Cpt(2) = 0 Then Exit Sub
'couples
For i = y To RwT
Cpt(3) = Cpt(3) + 1
If Cpt(3) = 1 Then
ReDim Tdc(1 To 3, 1 To 1)
Else
ReDim Preserve Tdc(1 To 3, 1 To Cpt(3))
End If
Tdc(1, Cpt(3)) = oT.Cells(i, 1): Tdc(2, Cpt(3)) = oT.Cells(i, 2)
For j = 1 To Cpt(3) - 1
If Tdc(1, Cpt(3)) = Tdc(1, j) And Tdc(2, Cpt(3)) = Tdc(2, j) Then
Cpt(3) = Cpt(3) - 1: ReDim Preserve Tdc(1 To 3, 1 To Cpt(3)): Exit For
End If
If Tdc(1, Cpt(3)) = Tdc(2, j) And Tdc(2, Cpt(3)) = Tdc(1, j) Then
Cpt(3) = Cpt(3) - 1: ReDim Preserve Tdc(1 To 3, 1 To Cpt(3)): Tdc(3, j) = 1: Exit For
End If
Next j
Next i
For i = 1 To Cpt(3)
If Tdc(3, i) = 1 Then
Cpt(3) = Cpt(3) + 1: ReDim Preserve Tdc(1 To 3, 1 To Cpt(3))
Tdc(1, Cpt(3)) = Tdc(2, i): Tdc(2, Cpt(3)) = Tdc(1, i): Tdc(3, Cpt(3)) = 1
End If
Next i
'séquences
Dl = r - 1: Fl = Dl + 1: oS.Cells(Fl, c) = Tdb(1)
For i = 1 To Cpt(2)
If i > 1 Then Fl = Dl + 1
oS.Cells(Fl, c) = Tdb(i)
Do
Dl = oS.Cells(Rows.Count, c).End(xlUp).Row: ReDim Tdd(1 To 4, Fl To Dl)
For j = Fl To Dl
k = c
Do
If oS.Cells(j, k) = "" Then Exit Do
k = k + 1
Loop
Tdd(1, j) = oS.Cells(j, k - 1): Tdd(2, j) = k - 1
If k - c >= 2 Then
m = 1
Do While m <= k - 1 - c
Cc = 0
For n = 1 To m
If k - n - m >= c Then
If oS.Cells(j, k - n) = oS.Cells(j, k - n - m) Then Cc = Cc + 1
Else
Exit For
End If
Next n
If Cc = m Then
Tdd(3, j) = True: oS.Range(oS.Cells(j, k - 2 * m), oS.Cells(j, k - 1)).Font.Color = 255: Exit Do
End If
m = m + 1
Loop
End If
Tdd(4, j) = False
Next j
Cpt(4) = 0: Cpt(5) = 0
For j = Fl To Dl
For k = 1 To Cpt(3)
If Tdd(3, j) = True Then Exit For
If Tdc(1, k) = Tdd(1, j) Then
If Tdd(4, j) = True Then
Cpt(4) = Cpt(4) + 1
For m = c To Tdd(2, j)
oS.Cells(Dl + Cpt(4), m) = oS.Cells(j, m)
Next m
oS.Cells(Dl + Cpt(4), m) = Tdc(2, k)
Else
Cpt(5) = Cpt(5) + 1: oS.Cells(j, Tdd(2, j) + 1) = Tdc(2, k): Tdd(3, j) = False: Tdd(4, j) = True
End If
End If
Next k
Next j
Loop Until Cpt(4) + Cpt(5) = 0
Next i
For i = r To oS.Cells(r, c).End(xlDown).Row
Rd = 0: a = c
Do
If oS.Cells(i, a) = "" Then Exit Do
If oS.Cells(i, a).Font.Color = 255 Then Rd = Rd + 1
a = a + 1
Loop
If Rd > 0 Then
oS.Range(oS.Cells(i, a - Rd / 2), oS.Cells(i, a - 1)).ClearContents
End If
Next i
End Sub
