Option Explicit
Sub Extraction_base()
Dim Base As Worksheet
Dim paravb As Worksheet
Set Base = Worksheets("Base")
Dim val_critère_princ, s, nb_crit_sec, ligne, b, c, i, j, k, l, m, t, p, test, colonne, Index, lstrow, lstcol, nbchamps, col_critère_princ, col_critère_sec As Integer
Dim chemin As String
Dim var_temp_5, Message, Message2, Titre, Message3, Titre3, Message4, Titre4, Message5, Titre2, Titre5, Default, MyValue, MyValue2, Resultat
' Définit le message.
'Message = "Précisez le chemin pour atteindre le dossier de traitement"
'Titre = "Chemin" ' Définit le titre.
' Affiche le message, le titre et la valeur par défaut.
'MyValue = InputBox(Message, Title, Default)
' Définit le message.
'Message2 = "Précisez le nom du fichier à traiter - Ne pas oublier l'extension .xls"
'Titre2 = "Fichier" ' Définit le titre.
' Affiche le message, le titre et la valeur par défaut.
'MyValue2 = InputBox(Message2, Titre2, Default)
' chemin = MyValue
' fichier = MyValue2
' Set fs = Application.FileSearch
'With fs
' .LookIn = chemin
' .Filename = fichier
' .MatchTextExactly = True
' If .Execute > 0 Then
'Workbooks.Open Filename:=MyValue & "\" & MyValue2
'End If
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "N'oubliez pas de cocher dans la 1ère ligne de votre fichier les cases correspondant aux colonnes que vous voulez extraire. Si vous ne l'avez pas encore fait, cliquez sur Cancel"
Style = vbOKCancel
Title = "Attention"
Help = "DEMO.HLP" ' Définit le fichier d'aide.
Ctxt = 1000 ' Définit le contexte de
' la rubrique.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = 2 Then
Exit Sub
End If
lstrow = Base.Range("A65536").End(xlUp).Row
lstcol = Base.Range("IF1").End(xlUp).Column
nbchamps = 0
For t = 1 To 256
If Base.Cells(1, t) <> "" Then
nbchamps = nbchamps + 1
End If
Next
'créer un nouvel onglet "paravb"
Set paravb = Sheets.Add(Type:=xlWorksheet)
Sheets("Feuil1").Select
Sheets("Feuil1").Name = "paravb"
Set paravb = Worksheets("paravb")
'Choix du critère principal
'Définit le message.
Message3 = "Précisez le numéro de colonne du critère principal qui servira à la création des onglets"
Titre3 = "Critère principal" ' Définit le titre.
' Affiche le message, le titre et la valeur par défaut.
Resultat = InputBox(Message3, Titre3, Default)
col_critère_princ = Resultat * 1
paravb.Cells(1, 1) = "Critère principal"
paravb.Cells(2, 1) = Base.Cells(2, col_critère_princ)
'Liste des différentes valeurs du critère principal
b = 4
i = 0
paravb.Cells(3, 1) = Base.Cells(3, col_critère_princ)
For i = 4 To 76
c = 0
test = 0
For c = 1 To b - 1
If Base.Cells(i, col_critère_princ) = paravb.Cells(c, 1) Then
test = test + 1
End If
Next
If test = 0 Then
paravb.Cells(b, 1) = Base.Cells(i, col_critère_princ)
b = b + 1
End If
Next
Base.Activate
'Choix des critères secondaires
'Définit le message.
Message4 = "Combien de critères secondaires souhaitez-vous prendre en compte pour cette extraction ?"
Titre4 = "Nb critères secondaires" ' Définit le titre.
' Affiche le message, le titre et la valeur par défaut.
nb_crit_sec = InputBox(Message4, Titre4, Default)
For s = 1 To nb_crit_sec
Message5 = "Précisez le numéro de colonne du critère secondaire n° " & s
Titre5 = "Critère secondaire n° " & s ' Définit le titre.
' Affiche le message, le titre et la valeur par défaut.
var_temp_5 = InputBox(Message5, Titre5, Default)
col_critère_sec = var_temp_5 * 1
paravb.Cells(1, s + 1) = "Critère secondaire " & s
paravb.Cells(2, s + 1) = Base.Cells(2, col_critère_sec)
'Liste des différentes valeurs des critères secondaires
b = 4
i = 0
paravb.Cells(3, s + 1) = Base.Cells(3, col_critère_sec)
For i = 4 To lstrow
c = 0
test = 0
For c = 1 To b - 1
If Base.Cells(i, col_critère_sec) = paravb.Cells(c, s + 1) Then
test = test + 1
End If
Next
If test = 0 Then
paravb.Cells(b, s + 1) = Base.Cells(i, col_critère_sec)
b = b + 1
End If
Next
Next
'Définir les valeurs des différents critères sélectionnés
Dim f As Range
'ListBox1.Clear
'For Each f In paravb.Range("a1")
' If f.Value = "" Then Exit For
'ListBox1.AddItem f.Value
'Next
'boucle For à mettre en place pour chaque valeur (v) sélectionnées du critère principal - pour l'instant exemple avec la seule valeur 75
val_critère_princ = "75"
i = 0
m = 1
l = 2
Dim CP1 As Worksheet
Set CP1 = Sheets.Add(Type:=xlWorksheet)
Sheets("Feuil2").Select
Sheets("Feuil2").Name = paravb.Cells(2, 1) & " = " & val_critère_princ
Set CP1 = Worksheets(paravb.Cells(2, 1) & " = " & val_critère_princ)
'quand la boucle for sera mise en place:
'Dim CP&v as worksheet
'CP&v=worksheets(paravb.Cells(2, 1) & " = " & val_critère_princ)
paravb.Activate
'Boucle de remplissage onglet
For i = 3 To lstrow + 3
If Base.Cells(i, 1) <> "" Then
If Base.Cells(i, col_critère_princ).Text = val_critère_princ Then
j = 1
k = 1
For m = 1 To lstcol
Do While Base.Cells(2, j) <> ""
If Base.Cells(1, j) <> "" Then
'Titre
CP1.Cells(1, k) = Base.Cells(2, j)
'Remplissage cellules
CP1.Cells(l, k) = Base.Cells(i, j)
k = k + 1
End If
j = j + 1
Exit Do
Loop
Next
End If
End If
l = l + 1
Next
'Fin de boucle de remplissage onglet
'Mise en forme 1ère ligne
Rows("1:1").Select
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
Tu as utilisé vbOkCancel pour définir ta boîte. C'est bien. Maintenant, vérifie la réponse avec vbOk et vbCancel.
