1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
| Sub Conte_2()
Dim FL1 As Worksheet, Cell As Range, Code As Integer, Conte As Long
Dim DerLig As Long, Zone As Range
Dim adres As String, NoLig As Long, Var, Ecrit, NoCol As Integer
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
'Instance de la feuille : Permet d'utiliser FL1 partout dans ...
'... le code à la place de Worksheets("Conte2")
Set FL1 = ActiveSheet
'Fixe le N° de première colonne de la plage à lire
Code = 5
'Fixe le N° de la dernière colonne de la plage à lire
Conte = 2
' Ecrit écrémente la colonne d'écriture
Ecrit = 1
'Détermine la dernière ligne renseignée de la feuille de calculs
DerLig = Split(FL1.UsedRange.Address, "$")(4)
With FL1
Set Zone = .Range(FL1.Cells(5, Code), FL1.Cells(DerLig, Code))
'Utilisation de l'objet range (Cell) dans une boucle For Each... Next
For Each Cell In Zone
' i écrémente la ligne de la colonne Conte34
For i = 5 To DerLig
' j écrémente la ligne de la colonne Code
' Var écrémente j
For j = 5 To DerLig
'Si cellule code = cellule conte et que la valeur est différente de XYX
If Cells(j, Code).Value = Cells(i, Conte).Value And Cells(j, Code).Value <> "XYX" Then
Var = 0
'tant que code est inférieur à conte
Do While Var < WorksheetFunction.CountA(FL1.Columns(2))
If Cells(j + Var, Code).Value = Cells(i + Var, Conte).Value Then
'sélectionner la cellule dessous
Cells(j + Var, Code).Select
'écrire la lettre dans la cellule
ActiveCell.Offset(0, Ecrit).Value = Cells(j + Var, Code)
'colorier la cellule
ActiveCell.Offset(0, Ecrit).Interior.Color = Cells(i + Var, Conte).Interior.Color
Else
'efface les groupes de cellules inférieur à 6
If Var < 5 Then
Var = Var - 1
Range(ActiveCell.Offset(0, Ecrit), ActiveCell.Offset(-Var, Ecrit)).Clear
End If
j = j + Var
Exit Do
End If
Var = Var + 1
Loop
End If
'si c'est la fin de code
If Cells(j, Code).Value = "XYX" Then
'colonne suivante
i = i + 1
'retour en début de ligne et le compteur rajoute 1 après la boucle
j = 4
Ecrit = Ecrit + 1
'Si la cellule + 4 = XYX, on sort du programme
'le curseur est placé en haut de la feuille
ElseIf Cells(i + 4, Conte).Value = "XYX" Then
If ActiveSheet.Index < Sheets.Count Then
ActiveSheet.Next.Activate
i = 5
j = 5
Else
Cell(1, 1).Select
Exit Sub
End If
End If
Next
Next
Next
End With
End Sub |
Partager