XL 2019 Compléter une macro tirage au sort

[berru76]

Bonjour
J ai un début de macro pour un tirage au sort de récompense ou il me manque 2 éléments
malgré mes recherches je ne trouve pas de solution
Je joint un fichier pour exemple
Merci pour votre aide

Tirageausort
'
ActiveSheet.Select
Range("BQ26:BQ99").Select ' Il faudrait partir depuis la ligne colorée en jaune selon le nombre inscrit en CS8
Selection.Copy
Sheets("Tirage lot").Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C4:C99").Select
ActiveWorkbook.Worksheets("Tirage lot").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tirage lot").Sort.SortFields.Add(Range("C4:C99"), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
255, 255)
With ActiveWorkbook.Worksheets("Tirage lot").Sort
.SetRange Range("C3:C99")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=0
' Effacer les noms en bleu dans Sheets("Tirage lot") de C4 a C99

 

[bsalv]

Sub MacroTirageausort()
     '
     Dim i     As Integer, N1, N2

     With Sheets("96")
          i = .Range("CS8").Value            'à partir de cette cellule
          Set c = .Range("BQ4:BQ99")         'votre plage
          N1 = c.Rows.Count                  'nombre de lignes en total
          If 1 > i Or i > N1 Then
               MsgBox "erreur"
          Else
               N2 = N1 - i + 1               'nombre de lignes à copier
               Set c1 = c.Cells(i, 1).Resize(N2)     'plage à copier

               With Sheets("Tirage lot").Range("C3:C99")     'plage destination
                    .ClearContents           'RAZ
                    Application.Goto .Cells(1), 1
                    Set c2 = .Resize(N2)     'plage destination
                    c1.Copy                  'à partir de la  i-ième cellule           .PasteSpecial Paste:=xlPasteValues
                    c2.PasteSpecial xlValues

                    With c2
                         For i = 1 To N2     'boucler les cellules
                              With .Cells(i, 1)
                                   If .DisplayFormat.Interior.Color = RGB(183, 236, 255) Then .ClearContents     'si le couleur de la MFC est bleu clair alors vider cellule
                              End With
                         Next
                         With c2
                              .Sort .Range("A1"), xlAscending, Header:=xlNo     'trier la plage
                         End With
                    End With
               End With
          End If
     End With

End Sub

 

[berru76]

Sub MacroTirageausort()
     '
     Dim i     As Integer, N1, N2

     With Sheets("96")
          i = .Range("CS8").Value            'à partir de cette cellule
          Set c = .Range("BQ4:BQ99")         'votre plage
          N1 = c.Rows.Count                  'nombre de lignes en total
          If 1 > i Or i > N1 Then
               MsgBox "erreur"
          Else
               N2 = N1 - i + 1               'nombre de lignes à copier
               Set c1 = c.Cells(i, 1).Resize(N2)     'plage à copier

               With Sheets("Tirage lot").Range("C3:C99")     'plage destination
                    .ClearContents           'RAZ
                    Application.Goto .Cells(1), 1
                    Set c2 = .Resize(N2)     'plage destination
                    c1.Copy                  'à partir de la  i-ième cellule           .PasteSpecial Paste:=xlPasteValues
                    c2.PasteSpecial xlValues

                    With c2
                         For i = 1 To N2     'boucler les cellules
                              With .Cells(i, 1)
                                   If .DisplayFormat.Interior.Color = RGB(183, 236, 255) Then .ClearContents     'si le couleur de la MFC est bleu clair alors vider cellule
                              End With
                         Next
                         With c2
                              .Sort .Range("A1"), xlAscending, Header:=xlNo     'trier la plage
                         End With
                    End With
               End With
          End If
     End With

End Sub

Un grand merci a vous fonctionne parfaitement