Copie lignes sous conditions inputbox

  • Auteur de la discussion EIllon
  • Date de début

EIllon

Nouveau membre
BOnjour,

Voici une macro qui me permet de sélectionner les lignes correspondantes à la région parisienne (fonction du numéro département).



J'aimerai pouvoir sélectionner les départements par une msgbox pour sélectionner les départements qui m'intéressent et modifier par la même occasion le nom de la nouvelle feuille...

Code:
Sub select()
 
'déclaration des variables
' ------------------------
Dim numligne As Long
Dim départ As Integer
Dim numl As Integer
Dim n As Integer
 
 
 
 
' TRAITEMENT
' ----------
Application.ScreenUpdating = False
Sheets.Add.Name = "région parisienne"
 
Sheets("Fichier unique Antony").Select
numligne = 2
numl = 2
n = 1
Do
     départ = Int(Range("E" & numligne) / 1000)
     Select Case départ
          Case 2, 8, 10, 14, 18, 21, 22, 27, 28, 29, 35 To 37, 41, 44, 45, 49, 50 To 62, 67, 68, 70, 72, 76, 79 To 80, 85, 86, 88 To 90
' ne rien effacer
Case Else
               Range(numligne & ":" & numligne).Select
               x = x + 1
               Selection.Copy Sheets("Région parisienne").Range("A" & x)
               n = n + 1
               
End Select
      numligne = numligne + 1
Loop Until Range("E" & numligne) = ""
 
Application.ScreenUpdating = True
 
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
 
    Range("A1").End(xlDown).Offset(1, 0).Select
    
 End Sub
 

zeb

Modérateur
Quelques remarques sur ce code.
Puisque tu le publies, accepte qu'il soit critiqué. ;)

NE PAS FAIRE DE SELECT/SELECTION. Tu peux rechercher sur ce site, je le dis systématiquement.
Ce genre de code consomme tellement de ressources que tu as été obligé de faire des ScreenUpdating.

Au lien de faire :
Code:
Truc.Select
Selection.Machin
Fais directement :
Code:
Truc.Machin
C'est la sélection, le changement de focus, le rafraichissement de tout ça, qui consomment énormément.

x n'est pas défini, ni initialisé !
r n'est pas défini !
numl n'est pas utilisé.

La division entière s'écrit \ :
Code:
MsgBox 5 \ 2

Tu utilises une boucle Do .. Loop sans vérifier la première condition.

Tu utilises la collection Sheets. Tu peux être plus précis et utiliser Worksheets.

Tu utilises une énorme condition et tu ne te sers que de l'inverse (Case Else)
Inserve-la ! La région parisienne, c'est 8 départements seulement.


Code:
Sub CopieParDepartement(dep As Integer)
    ' // Source
    Dim cell_src As Range
    Dim ws_src As Integer
    
    ' // Destination
    Dim cell_dst As Range
    Dim ws_dst As Integer
    
    Set ws_src = Worksheets("Fichier unique Antony")
    Set cell_dst = ws_src.Cells(1, 1)

    Set ws_dst = Worksheets.Add
    ws_dst.Name = "Departement " & dep
    
    For Each cell_src In Range(ws_src.Range("E2"), ws_src.Range("E2").End(xlDown))
    	If cell_src.Value \ 1000 = dep Then
            cell_src.EntireRow.Copy cell_dst
            Set cell_dst = cell_dst.Offset(1)
    	End If    
    Next
        
    ...
    
End Sub

C'est bon pour un département ça, mais on veut des régions :
Code:
Sub CopieParDepartement(deps() As Integer, NomReg As String)
...
    Dim dep As Variant
    Dim ok As Boolean
...
    ws_dst.Name = NomReg
...
    For Each cell_src In ..
        ok = False
        For Each dep In deps
            If cell_src.Value \ 1000 = dep Then ok = True
        Next
        If ok Then
...

Pour réaliser l'interface, conçois une UserForm, avec la liste des régions.
Fais correspondre chaque item avec des départements :

A toi maintenant de proposer une inferface pour choisir la région :
Code:
Option Base 0

Dim Reg_IleDeFrance(8) As Integer
Dim Reg_Picardie(3) As Integer

Reg_IleDeFrance(0) = 75
Reg_IleDeFrance(1) = 77
Reg_IleDeFrance(2) = 78
Reg_IleDeFrance(3) = 91
Reg_IleDeFrance(4) = 92
Reg_IleDeFrance(5) = 93
Reg_IleDeFrance(6) = 94
Reg_IleDeFrance(7) = 95

Reg_Picardie(0) = 2
Reg_Picardie(1) = 60
Reg_Picardie(2) = 80

CopieParDepartement Reg_IleDeFrance, "Région Ile de France"


PS: Dans le mesure où ton code fonctionne, je ne te impose pas de le changer, juste d'étudier ce que je propose ;)
 

EIllon

Nouveau membre
merci, je commençais à désespérer, en fait je ne veux pas les mettre par région, parce que c'est moi qui défini les régions.
C'est pour ça que je veux pouvoir rentrer les départements qui m'intéressent du genre : 22, 56, 29, 44, 49.
Ils ne sont pas dans la même région, mais leur emplacement les mets ensemble.

Je suis administrateur logistique, j'ai un fichier de 1500 clients qui se maintiens (commandes, livraisons), pour faire les tournées des chauffeurs, je choisis des zones, ce qui me permet de ne pas mettre les 1500 clients sur la carte.

Je trouve que inputbox pourrait m'aider et me faire gagner du temps parce que pour le moment, je fais des copier coller dans mon classeur excel.

Pour être honnête, ce n'est pas moi qui est fais la macro, elle m'a été donnée sur un forum.
Je suis nul en vba, en fait je ne sais faire que le plus simple ou adapter celles déjà faites.

E fait, je cherche quelqu'un qui pourrait me la faire... C'est pas très cool mais je n'ai pas les moyens de me pencher dessus pour le moment et surtout pas le temps.
En passant, je cherche des bouquins bien fait pour apprendre.

Merci pour ton aide.
 

zeb

Modérateur
Je n'ai pas (plus) de bouquins à te conseiller, mais d'autres peuvent le faire. ;)

Et surtout ne dit pas trop fort que tu ne cherches qu'à faire faire ton boulot ! C'est très mal vu ici. Si le modo te surprend...

---------------------

Es-tu capable de faire un UserForm ?
C'est plutôt facile.

Les regroupements sont-ils toujours les mêmes ?
Ou toujours différents ?
 

EIllon

Nouveau membre
Merci, je veux bien me lancer à faire la macro, je prendrais le temps.
Juste je voudrais connaitre la manip pour inputbox.
Je voudrais savoir comment je peux rentrer les numéros de départements pour les copier dans une nouvelle feuille.
 

zeb

Modérateur
:)

Prends le soin de modifier un peu la première procédure :
Code:
Sub CopieParDepartement(deps() As String, NomReg As String)
   ...
End Sub

Puis regarde un peu ça :
Code:
Sub Saisie()
    Dim s As String
    
    Dim deps() As String
    Dim NomReg As String
    
    s = InputBox("Veuillez saisir les N° des départements, séparés par des virgules :")
    deps = Split(s, ",")
    
    s = InputBox("Veuillez saisir un nom pour la nouvelle feuille :")
    NomReg = s
    
    CopieParDepartement deps, NomReg
End Sub
 

EIllon

Nouveau membre
Voilà ce que j'ai pour le moment, mais ça ne marche pas...
ça bloque sur
Code:
Range(numligne & ":" & numligne).Select
               x = x + 1
               Selection.Copy Sheets("").Range("A" & x)
               n = n + 1

Code:
Sub test()

Dim numligne As Long
Dim depts As Integer
Dim n As Integer
Dim s As String
Dim deps() As String
Dim NomReg As String

' TRAITEMENT
' ----------
Application.ScreenUpdating = False
Sheets("Feuil1").Select
numligne = 1
n = 1


     depts = Int(Range("E" & numligne) / 1000)
        
   
        s = InputBox("Veuillez saisir les N° des départements, séparés par des virgules :")
        deps = Split(s, ",")
   
       s = InputBox("Veuillez saisir un nom pour la nouvelle feuille :")
       NomReg = s
        
                 
               Range(numligne & ":" & numligne).Select
               x = x + 1
               Selection.Copy Sheets("").Range("A" & x)
               n = n + 1
               

      numligne = numligne + 1


End Sub
 

EIllon

Nouveau membre
Après correction, je bloque sur la lignes pour copier dans la nouvelle feuille.

Code:
Sub CopieParDepartement(deps() As String, NomReg As String)
      
End Sub

Sub saisie()

Dim numligne As Long
Dim depts As Integer
Dim n As Integer
Dim s As String
Dim deps() As String
Dim NomReg As String

' TRAITEMENT
' ----------
Application.ScreenUpdating = False
Sheets("Feuil1").Select
numligne = 1
n = 1


     depts = Int(Range("E" & numligne) / 1000)
        
   
        s = InputBox("Veuillez saisir les N° des départements, séparés par des virgules :")
        deps = Split(s, ",")
   
       s = InputBox("Veuillez saisir un nom pour la nouvelle feuille :")
       NomReg = s
        CopieParDepartement deps, NomReg
                 
               Range(s & ":" & s).Copy Sheets(deps).Range("A" & x)
               
                n = n + 1

                numligne = numligne + 1


End Sub
 

zeb

Modérateur
M'enfin, c'est la fonction CopieParDepartement qui doit copier tes lignes.
 

EIllon

Nouveau membre
C'est bien ce qui me semblait, mais ça marche pas.
La nouvelle feuille ne se crée pas, pas de copie.
 

zeb

Modérateur
J'espère que
Code:
Sub CopieParDepartement(deps() As String, NomReg As String)

End Sub
n'est pas la totalité du code que tu utilises pour faire cette copie :heink:
 

EIllon

Nouveau membre
J'ai mis à la suite les deux codes (dans le même module).
J'ai bien les inputbox mais ça ne fait rien.
J'ai dû oublier quelque chose.
 

zeb

Modérateur
Mets un point d'arrêt dans une des macros (touche [F9])
Exécute normalement ta macro. Quand elle s'arrête, appuie sur [F8] pour dérouler ton programme pas-à-pas. Tu verras par où il passe ou ne passe pas.
 

EIllon

Nouveau membre
Je crois que le défaut, c'est que je n'ai pas rempli la macro
Sub CopieParDepartement
Si il y avait quelque chose à y mettre.
 

EIllon

Nouveau membre
Je m'approcherai bien du résultat avec ça, la nouvelle feuille est créée, mais les lignes choisi ne sont pas copier dans cette nouvelle feuille.

Code:
Sub saisie()

Dim numligne As Long
Dim depts As Integer
Dim n As Integer
Dim s As String
Dim deps() As String
Dim NomReg As String

numligne = 1
n = 1


     depts = Int(Range("E" & numligne) / 1000)
        
   
        s = InputBox("Veuillez saisir les N° des départements, séparés par des virgules :")
        deps = Split(s, ",")
   
       s = InputBox("Veuillez saisir un nom pour la nouvelle feuille :")
       NomReg = s
        CopieParDepartement deps, NomReg
                 
              
End Sub

Sub CopieParDepartement(deps() As String, NomReg As String)
      
Dim numligne As Long
Dim depts As Integer
Dim n As Integer
Dim s As String

Sheets.Add.Name = NomReg

      
      

               Selection.Copy Sheets = NomReg.Range("A" & x)
               n = n + 1
               
End Sub
 

zeb

Modérateur
M'enfin, là :
je te donne tout ce dont tu as besoin.

Faut-il que je te fasse à ta place ?
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Derniers messages publiés
Statistiques globales
Discussions
730 098
Messages
6 717 055
Membres
1 586 282
Dernier membre
Yannick3553
Partager cette page
Haut