VBAimport

Sub EchantillonParRégion_CorrigéFinal()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    Dim dictRegions As Object
    Set dictRegions = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    
    ' Identifier les régions
    For i = 3 To lastRow
        Dim region As String
        region = ws.Cells(i, "C").Value
        If Not dictRegions.exists(region) And region <> "" Then
            dictRegions.Add region, Nothing
        End If
    Next i

    Dim reg As Variant
    For Each reg In dictRegions.Keys
        Dim candidats As Collection
        Set candidats = New Collection
        
        Dim utilisés As Collection
        Set utilisés = New Collection
        
        ' Stocker les lignes candidates de cette région
        For i = 3 To lastRow
            If ws.Cells(i, "C").Value = reg Then
                candidats.Add i
            End If
        Next i
        
        Dim critèreTrouvé(1 To 5) As Boolean
        Dim lignesSélectionnées(1 To 5) As Long
        
        ' Critère 2 - PM
        Dim idx As Variant
        For Each idx In candidats
            If Not critèreTrouvé(2) And ws.Cells(idx, "K").Value = "PM" Then
                lignesSélectionnées(2) = idx
                critèreTrouvé(2) = True
                utilisés.Add idx
                Exit For
            End If
        Next idx
        
        ' Critère 3 - PP > 85 ans
        For Each idx In candidats
            If Not critèreTrouvé(3) And ws.Cells(idx, "K").Value = "PP" And ws.Cells(idx, "M").Value > 85 Then
                lignesSélectionnées(3) = idx
                critèreTrouvé(3) = True
                utilisés.Add idx
                Exit For
            End If
        Next idx
        
        ' Critère 4 - Op sur comptes titres en entrée
        For Each idx In candidats
            If Not critèreTrouvé(4) And ws.Cells(idx, "V").Value = "Op sur comptes titres en entrée" Then
                lignesSélectionnées(4) = idx
                critèreTrouvé(4) = True
                utilisés.Add idx
                Exit For
            End If
        Next idx
        
        ' Critère 5 - SC1 - Absence de conseil
        For Each idx In candidats
            If Not critèreTrouvé(5) And ws.Cells(idx, "AC").Value = "SC1 - Absence de conseil" Then
                lignesSélectionnées(5) = idx
                critèreTrouvé(5) = True
                utilisés.Add idx
                Exit For
            End If
        Next idx
        
        ' Critère 1 - Montant le plus élevé (hors déjà utilisés)
        Dim montantMax As Double: montantMax = -1
        Dim ligneMax As Long: ligneMax = 0
        
        For Each idx In candidats
            If Not EstDansCollection(utilisés, idx) Then
                If ws.Cells(idx, "U").Value > montantMax Then
                    montantMax = ws.Cells(idx, "U").Value
                    ligneMax = idx
                End If
            End If
        Next idx
        
        If ligneMax > 0 Then
            lignesSélectionnées(1) = ligneMax
            critèreTrouvé(1) = True
            utilisés.Add ligneMax
        End If
        
        ' Compléter les critères manquants avec montants restants
        Dim j As Integer
        For j = 1 To 5
            If lignesSélectionnées(j) = 0 Then
                Dim maxRestant As Double: maxRestant = -1
                Dim ligneRestant As Long: ligneRestant = 0
                
                For Each idx In candidats
                    If Not EstDansCollection(utilisés, idx) Then
                        If ws.Cells(idx, "U").Value > maxRestant Then
                            maxRestant = ws.Cells(idx, "U").Value
                            ligneRestant = idx
                        End If
                    End If
                Next idx
                
                If ligneRestant > 0 Then
                    lignesSélectionnées(j) = ligneRestant
                    utilisés.Add ligneRestant
                End If
            End If
        Next j
        
        ' Marquer les lignes sélectionnées avec "X" dans la colonne H
        For j = 1 To 5
            If lignesSélectionnées(j) > 0 Then
                ws.Cells(lignesSélectionnées(j), "H").Value = "X"
            End If
        Next j
    Next reg

    MsgBox "Échantillonnage terminé pour toutes les régions !"
End Sub

Function EstDansCollection(col As Collection, valeur As Variant) As Boolean
    Dim x
    For Each x In col
        If x = valeur Then
            EstDansCollection = True
            Exit Function
        End If
    Next x
    EstDansCollection = False
End Function

Sub EchantillonParRégion()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    Dim dictRegions As Object
    Set dictRegions = CreateObject("Scripting.Dictionary")

    Dim i As Long
    ' Récupérer toutes les régions uniques (colonne C)
    For i = 3 To lastRow
        Dim region As String
        region = ws.Cells(i, "C").Value
        If Not dictRegions.exists(region) And region <> "" Then
            dictRegions.Add region, Nothing
        End If
    Next i

    Dim reg As Variant
    For Each reg In dictRegions.Keys
        Dim candidats As Collection
        Set candidats = New Collection

        ' Récupérer toutes les lignes correspondant à la région
        For i = 3 To lastRow
            If ws.Cells(i, "C").Value = reg Then
                candidats.Add i
            End If
        Next i

        Dim lignesSélectionnées As Collection
        Set lignesSélectionnées = New Collection

        Dim idx As Variant

        ' 1. PM
        For Each idx In candidats
            If ws.Cells(idx, "K").Value = "PM" And Not EstDansCollection(lignesSélectionnées, idx) Then
                lignesSélectionnées.Add idx
                Exit For
            End If
        Next idx

        ' 2. PP > 85 ans
        For Each idx In candidats
            If ws.Cells(idx, "K").Value = "PP" And ws.Cells(idx, "M").Value > 85 And Not EstDansCollection(lignesSélectionnées, idx) Then
                lignesSélectionnées.Add idx
                Exit For
            End If
        Next idx

        ' 3. Op sur comptes titres en entrée
        For Each idx In candidats
            If ws.Cells(idx, "V").Value = "Op sur comptes titres en entrée" And Not EstDansCollection(lignesSélectionnées, idx) Then
                lignesSélectionnées.Add idx
                Exit For
            End If
        Next idx

        ' 4. SC1 - Absence de conseil
        For Each idx In candidats
            If ws.Cells(idx, "AC").Value = "SC1 - Absence de conseil" And Not EstDansCollection(lignesSélectionnées, idx) Then
                lignesSélectionnées.Add idx
                Exit For
            End If
        Next idx

        ' 5. Montant le plus élevé restant
        Dim montantMax As Double: montantMax = -1
        Dim ligneMax As Long: ligneMax = 0

        For Each idx In candidats
            If Not EstDansCollection(lignesSélectionnées, idx) Then
                If ws.Cells(idx, "U").Value > montantMax Then
                    montantMax = ws.Cells(idx, "U").Value
                    ligneMax = idx
                End If
            End If
        Next idx

        If ligneMax > 0 Then
            lignesSélectionnées.Add ligneMax
        End If

        ' Compléter si on a moins de 5 lignes
        Do While lignesSélectionnées.Count < 5
            montantMax = -1
            ligneMax = 0

            For Each idx In candidats
                If Not EstDansCollection(lignesSélectionnées, idx) Then
                    If ws.Cells(idx, "U").Value > montantMax Then
                        montantMax = ws.Cells(idx, "U").Value
                        ligneMax = idx
                    End If
                End If
            Next idx

            If ligneMax > 0 Then
                lignesSélectionnées.Add ligneMax
            Else
                Exit Do ' plus de lignes disponibles
            End If
        Loop

        ' Marquer les X dans la colonne H
        For Each idx In lignesSélectionnées
            ws.Cells(idx, "H").Value = "X"
        Next idx

    Next reg

    MsgBox "Échantillonnage terminé pour toutes les régions !"

End Sub

Function EstDansCollection(col As Collection, valeur As Variant) As Boolean
    Dim x
    For Each x In col
        If x = valeur Then
            EstDansCollection = True
            Exit Function
        End If
    Next x
    EstDansCollection = False
End Function