Sélection sur une partie de la valeur avec InputBox

Version imprimable

Bonjour à Tous,
La feuille sur laquelle je souhaite faire fonctionner cette macro se compose ainsi
L1 à 10 : Texte de présentation
L11 : Titre de mes colonnes A à M
En colonne C le titre est "CODE POSTAL"
La plage sur laquelle cette macro doit fonctionner est A12:M2012
La macro ci-dessous fonctionne très bien si on donne à InputBox ex: 75001 ou 45100.
Je voudrais pouvoir ne saisir que le numéro du département ex: 75 ou 45 et ensuite avoir le même scénario.
Merci de votre aide
Lenul

Code:

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
Sub SelectionCode()
Application.ScreenUpdating = False
Dim SelectionCode
Dim Colonne As Range
Dim LastLig As Long
 
With Sheets("Prospects")
    SelectionCode = InputBox("Entrez le CODE POSTAL")
    If SelectionCode <> "" Then
        LastLig = .Cells(Rows.Count, "C").End(xlUp).Row
        Set Colonne = .Range("C12:C" & LastLig).Find(What:=SelectionCode, LookIn:=xlValues, lookat:=xlWhole)
        If Colonne Is Nothing Then
            MsgBox "désolé ce CODE n'existe pas"
        Else
            With .Range("C11:C" & LastLig)
                .AutoFilter
                .AutoFilter field:=1, Criteria1:=SelectionCode
            End With
            OuvrirExtrait
            .Range("A12:M" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sheets("Extrait").Range("A12")
            .Range("C11:C" & LastLig).AutoFilter
            End If
        Set Colonne = Nothing
    End If
End With
Range("a11").Select
Sheets("Extrait").Select
Range("a11").Select
Application.ScreenUpdating = True
End Sub

Code:

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
Sub Selektion2()
Dim SelectionType
Dim Trouve As Boolean
Dim LastLig As Long, NewLig As Long
 
With Sheets("Prospects")
    SelectionType = InputBox("Entrez le CODE")
    If SelectionType <> "" Then
        SelectionType = SelectionType & "*"
        .Cells.AutoFilter
        LastLig = .Cells(Rows.Count, "L").End(xlUp).Row
        .Range("A11:L" & LastLig).AutoFilter field:=12, Criteria1:=SelectionType
        Trouve = False
        On Error Resume Next
        If .Range("L11:L" & LastLig).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then Trouve = True
        If Trouve Then
            NewLig = Sheets("Recap").Cells(Rows.Count, "L").End(xlUp).Row + 1
            .Range("A12:M" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sheets("Recap").Range("A" & NewLig)
        Else
            MsgBox "désolé ce TYPE n'existe pas"
        End If
        .Range("A11:L" & LastLig).AutoFilter
    End If
End With
End Sub

Bonjour,
je reviens vers Toi car après avoir adapté ton code à ma feuille "Prospects", celui-ci ce déroule sans message d'erreur mais aucune sélection n'est copiée sur la feuille "Extrait".
J'ai essayé des modif mais sa plante à chaque fois..... Et oui je suis NUL:oops:
Pour mémoire la constitution de "Prospects" :
A1 à M10 : Texte de présentation
Ligne11 : Titre de mes colonnes A à M
En colonne C le titre est "CODE POSTAL" format "code postal" (pour le test, j'ai dans cette colonne c12=75001;c13=75100;c14=92500 et c15=15230)
La plage sur laquelle cette macro doit fonctionner est A12:M2012
But de la macro: sélectionner les lignes qui dans la colonne "CODE POSTAL" ont les 2 premiers chiffres = à la saisie de InputBox ensuite copier ces lignes sur une feuille nommée "Extrait".
Voici ton code modifié avec les bonnes colonnes:
Merci de ton aide
Lenul
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 Sub Selektion2() Dim SelectionDept Dim Trouve As Boolean Dim LastLig As Long, NewLig As Long With Sheets("Prospects") SelectionDept = InputBox("Entrez le numéro de Département") If SelectionDept <> "" Then SelectionDept = SelectionDept & "*" .Cells.AutoFilter LastLig = .Cells(Rows.Count, "C").End(xlUp).Row .Range("A11:L" & LastLig).AutoFilter field:=3, Criteria1:=SelectionDept Trouve = False On Error Resume Next If .Range("C11:C" & LastLig).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then Trouve = True If Trouve Then NewLig = Sheets("Extrait").Cells(Rows.Count, "C").End(xlUp).Row + 1 .Range("A12:M" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sheets("Extrait").Range("A" & NewLig) Else MsgBox "désolé ce DEPARTEMENT n'existe pas" End If .Range("A11:L" & LastLig).AutoFilter End If End With

Les codes postaux sont interprétés comme des nombres.
j'ai modifié le code. j'avoue que ce n'est pas peut être la meilleure méthode
ci-joint code:

Code:

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
Dim SelectionDept
Dim vCel As Range
Dim Trouve As Boolean
Dim LastLig As Long, NewLig As Long
 
With Sheets("Prospects")
    SelectionDept = InputBox("Entrez le numéro de Département")
    If SelectionDept <> "" Then
        SelectionDept = CStr(SelectionDept) & "*"
        .Range("A11:L11").AutoFilter
        LastLig = .Cells(Rows.Count, "C").End(xlUp).Row
        If LastLig > 11 Then
            For Each vCel In .Range("C12:C" & LastLig)  'on modifie le type du contenu de la colonne C
                vCel.Value = CStr(vCel.Value)
            Next vCel
        End If
        .Range("A11:L" & LastLig).AutoFilter field:=3, Criteria1:=SelectionDept
        Trouve = False
        On Error Resume Next
        If .Range("C11:C" & LastLig).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then Trouve = True
        If Trouve Then
            NewLig = Sheets("Extrait").Cells(Rows.Count, "C").End(xlUp).Row + 1
            .Range("A12:M" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sheets("Extrait").Range("A" & NewLig)
        Else
            MsgBox "désolé ce DEPARTEMENT n'existe pas"
        End If
        .Range("A11:L" & LastLig).AutoFilter
    End If
End With
End Sub

26/03/2010, 11h51
lenul78570

Re,
J'ai testé ton code mais avec la saisie soit de 75, 92 ou 15 la macro me renvoi le message que ce département n'existe pas !
Je vois pas ou est l'erreur
Lenul
26/03/2010, 12h12
mercatog

J'ai testé sur un fichier test avant de poster
ci-joint. à adapter à ta feuille
26/03/2010, 16h00
lenul78570

En effet sur ton fichier cela fonctionne.....
pas sur le mien.... Je cherche...!
28/03/2010, 11h54
lenul78570

Bonjour
C'est bon ça foctionne!
Merci de ton aide
Lenul