Microsoft 365 Choix et export de données (Résolu)

Option Explicit
Sub RemplirExportManches()
    Dim wsBase As Worksheet
    Dim wsExport As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim countTheme1 As Long, countTheme2 As Long, countTheme3 As Long, countTheme4 As Long, countTheme5 As Long
    
    ' Spécifiez la feuille "Base" et "Export"
    Set wsBase = ThisWorkbook.Sheets("Base")
    Set wsExport = ThisWorkbook.Sheets("Export")
    
    ' Déterminer la dernière ligne de la colonne A dans la feuille "Base"
    lastRow = wsBase.Cells(wsBase.Rows.count, "A").End(xlUp).Row
    
    ' Initialiser le compteur de thèmes
    countTheme1 = 0
    countTheme2 = 0
    countTheme3 = 0
    countTheme4 = 0
    countTheme5 = 0
    
    ' Parcourir la colonne A à partir de la ligne 5
    For i = 5 To lastRow
        Select Case wsBase.Cells(i, 15).Value ' Colonne O
            Case 1
                countTheme1 = countTheme1 + 1
                If countTheme1 <= 10 Then
                    wsExport.Cells(18, 1).Value = "1/6" & vbCrLf & vbCrLf & vbCrLf & "Theme: " & wsBase.Cells(i, 19).Value
                End If
            Case 2
                countTheme2 = countTheme2 + 1
                If countTheme2 <= 10 Then
                    wsExport.Cells(29, 1).Value = "2/6" & vbCrLf & vbCrLf & vbCrLf & "Theme: " & wsBase.Cells(i, 19).Value
                End If
            Case 3
                countTheme3 = countTheme3 + 1
                If countTheme3 <= 10 Then
                    wsExport.Cells(43, 1).Value = "3/6" & vbCrLf & vbCrLf & vbCrLf & "Theme: " & wsBase.Cells(i, 19).Value
                End If
            Case 4
                countTheme4 = countTheme4 + 1
                If countTheme4 <= 10 Then
                    wsExport.Cells(54, 1).Value = "4/6" & vbCrLf & vbCrLf & vbCrLf & "Theme: " & wsBase.Cells(i, 19).Value
                End If
            Case 5
                countTheme5 = countTheme5 + 1
                If countTheme5 <= 10 Then
                    wsExport.Cells(68, 1).Value = "5/6" & vbCrLf & vbCrLf & vbCrLf & "Theme:: " & wsBase.Cells(i, 19).Value
                End If
        End Select
    Next i
    
    ' Vérifier s'il y a moins de 10 choix par nombre
    If countTheme1 < 10 Then MsgBox "Il manque des choix pour le thème 1."
    If countTheme2 < 10 Then MsgBox "Il manque des choix pour le thème 2."
    If countTheme3 < 10 Then MsgBox "Il manque des choix pour le thème 3."
    If countTheme4 < 10 Then MsgBox "Il manque des choix pour le thème 4."
    If countTheme5 < 10 Then MsgBox "Il manque des choix pour le thème 5."
    
    ' Vérifier s'il y a plus de 10 choix sélectionnés
    If countTheme1 > 10 Then MsgBox "Il y a plus de 10 choix sélectionnés pour le thème 1."
    If countTheme2 > 10 Then MsgBox "Il y a plus de 10 choix sélectionnés pour le thème 2."
    If countTheme3 > 10 Then MsgBox "Il y a plus de 10 choix sélectionnés pour le thème 3."
    If countTheme4 > 10 Then MsgBox "Il y a plus de 10 choix sélectionnés pour le thème 4."
    If countTheme5 > 10 Then MsgBox "Il y a plus de 10 choix sélectionnés pour le thème 5."
    
DesactiverRetourAutomatique
    
End Sub

Sub DesactiverRetourAutomatique()
    Dim ws As Worksheet
    Dim rng As Range
    
    ' Spécifie la feuille de calcul "Export"
    Set ws = ThisWorkbook.Sheets("Export")
    
    ' Spécifie les cellules à modifier
    Set rng = ws.Range("A18,A29,A43,A54,A68")
    
    ' Désactive le retour automatique à la ligne
    rng.WrapText = False
End Sub