Creer zone de saisie

Le 01/07/2015 à 09:42

Bonjour

j ai besoin d un coup de main svp

j ai fait un classeur que je poste en piece jointe pour etailler mes propos

la zone de saisie se trouve ligne 4

qd on rentre en ligne 4 la date et le temps de vol j aimerais que c est informations s enregistre dans les tableaux en dessous

ainsi

lorsque je rentre :

15/01/15 et 4:00 celle ci vont se ranger automatiquement ligne 8

lorsque je rentre

10/03/15 et 5:15 ces infos vont se ranger ligne 25

lorsque je rentre ligne 4 toujours :

03/02/15 et 3:42 ces infos vont se ranger ligne 16

et pour finir

lorsque je rentre :

12/01/15 et 4:00 ces infos vont se ranger ligne 8 et decaler les infos au prealable ranger en ligne 8 ( a savoir 15/01/15 et 4:00 )a la ligne 9

Merci d avance

10338952d1435681217-zone-de-saisie-et-enregistrement-flight-hours.xlsx (8.54 Ko)
Le 01/07/2015 à 10:56

Bonjour le forum,

Une macro à placer dans le composant de l'onglet concerné Feuil1(Feuil1) :

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim M As String 'déclare la variable M (Mois)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

If Target.Address = "$C$4" Then 'condition 1 : si le changement a lieu en C4
    If Target.Offset(0, -1).Value <> "" Then 'condition 2 : si C3 n'est pas vide
        If IsDate(Target.Offset(0, -1).Value) = True Then 'condition 3 : si C3 est une date
            D = CDate(Target.Offset(0, -1).Value) 'définit la date D
        Else 'sinon (si C3 n'est pas une date
            MsgBox "Date invalide !" 'message
            Target.Offset(0, -1).Select 'sélectionne C3
            Exit Sub 'sort de la procédure
        End If 'fin de la condition 3
        M = Format(D, "mmmm") 'définit le mois M
        Set R = Cells.Find(M, , xlValues, xlWhole) 'de'finit la recherche R (recherche le mois entier dans l'onglet)
        If Not R Is Nothing Then 'condition 4 : si il existe au moins une occurrence trouvée
            Set DEST = IIf(R.Offset(1, 0) = "", R.Offset(1, 0), R.End(xlDown).Offset(1, 0)) 'de'finit la cellule de destination DEST
            DEST.Value = D 'renvoie la date D dans DEST
            Target.Copy 'copy C4
            DEST.Offset(0, 1).PasteSpecial (xlPasteAllExceptBorders) 'colle sans les bordures dans DEST décalée du'une colonne à droite
        End If 'fin de la condition 4
    End If 'fin de la condition 2
    Range("B4:C4").ClearContents 'efface la plage B4:C4
End If 'fin de la condition 1
End Sub

Pour quelle fonctionne il faut que les mois soient écrits avec les accents (février,août, décembre). Que va-t-il se passer pour la 7ème date de janvier ??? Je n'ai pas compris tes tableaux de tailles différentes.

Le 01/07/2015 à 11:04

Bonjour, l0l0tte

A tester avec un UserForm qui sélectionne les mois

Amicalement

Pierrot

13zone-de-saisie-et-enregistrement-flight-hours.xlsm (24.87 Ko)
Le 01/07/2015 à 11:27

Merci pour vos réponses si rapide

Je regarde ca plus en profondeur cet après midi

Pour les tableaux des mois je ne voulais pas mettre 31 lignes correspondant au jours de chaque mois car je n ai pas autant d entrée

Je voudrais qu une ligne se crée automatiquement après la derniere

Le 01/07/2015 à 12:14

Bonjour le fil, bonjour le forum,

Moi je te conseillerais plutôt d'utiliser une paire de colonnes pour chaque mois. Car rajouter une ligne à la fin ça va être un peu plus complexe. En plus, le code que je t'ai proposé fonctionnera toujours...

Le 01/07/2015 à 13:50

Re

j ai verifié le code ca marche nickel merci thauthème

desolé Pierre ca correspond plus a ce que je voulais

Par contre le top ca aurait ete que les dates s ordonnent automatiquement dans les tableaux en dessous

Aussi je pense que c est pas nessecaire de préciser le contenu des cellules comme ca je pourrai l adapter a plusieurs cellules par lignes

Et puis la j abuse peut être mais oui le truc ultime se serait que les tableaux du dessous s adaptent (ligne supplémentaire) si il a une nouvelle entrée

Si vous pouvez me faire ca serait super , si le dernier truc c est trop compliqué , bah tant pis

Merci encore

Le 01/07/2015 à 14:53

Bonjour le fil, bonjour le forum,

En pièce jointe ton fichier modifié. Il ne faut surtout pas effacer les lignes contenant le mot fin car elles me servent de repère pour l'ajout de ligne et le tri...

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim M As String 'déclare la variable M (Mois)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)

If Target.Address = "$C$4" Then 'condition 1 : si le changement a lieu en C4
    If Target.Offset(0, -1).Value <> "" Then 'condition 2 : si C3 n'est pas vide
        If IsDate(Target.Offset(0, -1).Value) = True Then 'condition 3 : si C3 est une date
            D = CDate(Target.Offset(0, -1).Value) 'définit la date D
        Else 'sinon (si C3 n'est pas une date)
            MsgBox "Date invalide !" 'message
            Target.Offset(0, -1).Select 'sélectionne C3
            Exit Sub 'sort de la procédure
        End If 'fin de la condition 3
        M = Format(D, "mmmm") 'définit le mois M
        Set R = Cells.Find(M, , xlValues, xlWhole) 'définit la recherche R (recherche le mois entier dans l'onglet)
        If Not R Is Nothing Then 'condition 4 : si il existe au moins une occurrence trouvée
            Set DEST = IIf(R.Offset(1, 0) = "", R, R.End(xlDown)) 'définit la cellule de destination DEST
            If DEST.Value = "fin" Then 'condition 5 : si DEST vaut "fin"
                Rows(DEST.Row).Insert shift:=xlDown 'insère une ligne au dessus
                Set DEST = DEST.Offset(-1, 0) 'redéfinit DEST une ligne au dessus
            Else 'sinon
                Set DEST = DEST.Offset(1, 0) 'redéfinit DEST une ligne au dessous
            End If 'fin de la condition 5
            DEST.Value = D 'renvoie la date D dans DEST
            Target.Copy 'copie C4
            DEST.Offset(0, 1).PasteSpecial (xlPasteAllExceptBorders) 'colle sans les bordures dans DEST décalée du'une colonne à droite
        End If 'fin de la condition 4
    End If 'fin de la condition 2
    Range("B4:C4").ClearContents 'efface la plage B4:C4
    Set PL = R.CurrentRegion 'définit la plage PL
    Set PL = PL.Offset(1, 0).Resize(PL.Rows.Count - 2, PL.Columns.Count) 'redéfinit la plage PL (sans la premiere et la derniere ligne)
    'tri du mois
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    Sheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(2), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(3), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange PL
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End If 'fin de la condition 1
End Sub
7lolotte-v01.xlsm (19.36 Ko)
Le 01/07/2015 à 15:15

Ah merci c est du gold job

Une dernière requête ,qu est ce que ca donne avec 4 cellules sur la mm lignes

j ai modifié un peu le classeur juste sur les premiers mois

Après ca je vous embete plus

10lolotte-v01.xlsm (18.87 Ko)
Le 01/07/2015 à 15:59

Bonjour le fil, bonjour le forum,

Ce qui complique dorénavant c'est à quel moment faut-il déclencher la macro ? Avant, je déclenchais à la modification de C4 si B4 était remplie. Maintenant, je ne sais pas si les 2 nouveaux champs sont obligatoires. Si c'est le cas, je peux déclencher à la modification de E4 en testant que ni B4, ni C4, ni D4 ne soient vides. Sinon, pour éviter une usine à gaz, le plus simple serait de rajouter un bouton dans lequel l'utilisateur cliquerait quand il veut renvoyer les données dans les tableaux des mois... Mais on perd ainsi l'automatisme qui existait.

Qu'en dis-tu ?

Le 01/07/2015 à 17:01

Pour te répondre exactement il aura 13 cellules a remplir et c est seulement a la dernière que le rangement se lance

Non j aimerais que ca se fasse automatiquement sans bouton

Le 01/07/2015 à 21:11

Re,

En pièce jointe la version 2 prévue pour 13 données avec le code ci-dessous :

Private TEST As Boolean 'déclare la variable TEST

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim PLD As Range 'déclare la varialbe PLD (PLage de Données)
Dim M As String 'déclare la variable M (Mois)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)

On Error GoTo fin 'gestion des erreurs, en cas d'erreur va à l'étiquette "fin" (permet à l'événement Change de touner après un plantage)
If TEST = True Then Exit Sub 'si TEST est [Vrai], sort de la procédure
Set PLD = Range("B4:N4") 'définit la plage PLD
'condition 1 : si le changement a lieu en N4 ou si la ligne 4 contient 13 valeurs
If Target.Address = "$N$4" Or Application.WorksheetFunction.CountA(Rows(Target.Row)) = 13 Then
    If Application.WorksheetFunction.CountA(Rows(Target.Row)) <> 13 Then 'condition 2 : si la ligne 4 ne contient pas 13 valeurs
        If Range("B4").Value = "" Then Range("B4").Select Else Range("B4").End(xlToRight).Offset(0, 1).Select 'sélectionne la cellule vide
        MsgBox "Il manque des données !" 'message
        TEST = False 'reinitialise la variable TEST
        Exit Sub 'sort de la procédure
    Else 'sinon
        TEST = True 'redéfinit la variable TEST
    End If 'fin de la condition 2
    If IsDate(Range("B4").Value) = True Then 'condition 3 : si B4 est une date
        D = CDate(Range("B4").Value) 'définit la date D
    Else 'sinon (si B4 n'est pas une date)
        MsgBox "Date non valide !" 'message
        Range("B4").Select 'sélectionne B4
        TEST = False 'réinitialise la variable TEST
        Exit Sub 'sort de la procédure
    End If 'fin de la condition 3
    M = Format(D, "mmmm") 'définit le mois M
    Set R = Cells.Find(M, , xlValues, xlWhole) 'définit la recherche R (recherche le mois entier dans l'onglet)
    If Not R Is Nothing Then 'condition 4 : si il existe au moins une occurrence trouvée
        Set DEST = IIf(R.Offset(1, 0) = "", R, R.End(xlDown)) 'définit la cellule de destination DEST
        If DEST.Value = "fin" Then 'condition 5 : si DEST vaut "fin"
            Rows(DEST.Row).Insert shift:=xlDown 'insère une ligne au dessus
            Set DEST = DEST.Offset(-1, 0) 'redéfinit DEST une ligne au dessus
        Else 'sinon
            Set DEST = DEST.Offset(1, 0) 'redéfinit DEST une ligne au dessous
        End If 'fin de la condition 5
        PLD.Copy 'copie la plage PLD
        DEST.PasteSpecial (xlPasteAllExceptBorders) 'colle sans les bordures dans DEST
    End If 'fin de la condition 4
    PLD.ClearContents 'efface la plage PLD
    Set PL = R.CurrentRegion 'définit la plage PL
    Set PL = PL.Offset(1, 0).Resize(PL.Rows.Count - 2, PL.Columns.Count) 'redéfinit la plage PL (sans la premiere et la derniere ligne)
    'tri du mois
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    Sheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(2), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(3), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange PL
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B4").Select 'sélectionne la cellule B4
End If 'fin de la condition 1
fin: 'étiquette
Err.Clear 'efface l'erreur
TEST = False 'réinitialise la variable TEST
End Sub

Sub macro1() 'si le renvoie dans les tableaux de mois ne fonctionne plus, lancer cette macro et retester
TEST = False 'réinitialise la variable TEST
End Sub
17lolotte-v02.xlsm (22.28 Ko)
Le 04/07/2015 à 10:08

Bonjour

Désolée vous avoir laissé sans nouvelle quelques jours j étais parti a l etranger

En tout cas ca marche trop bien

Il y ajuste une chose que j avais pas anticipé

La 9 eme cellule de la ligne 4 est la somme de la cellule 7 et 8 de la mm ligne

Hors a la fin de la macro ca efface les lignes donc je n ai plus la fonction somme dans cette case

Peut on remédier a ca ?

Le 04/07/2015 à 17:08

Bonjour Lolotte, bonjour le forum,

Heu... je croyais que tu devais plus m'embêter ?!... Le code modifié :

Private TEST As Boolean 'déclare la variable TEST

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
Dim PLD As Range 'déclare la varialbe PLD (PLage de Données)
Dim M As String 'déclare la variable M (Mois)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)

On Error GoTo fin 'gestion des erreurs, en cas d'erreur va à l'étiquette "fin" (permet à l'événement Change de touner après un plantage)
If TEST = True Then Exit Sub 'si TEST est [Vrai], sort de la procédure
Set PLD = Range("B4:N4") 'définit la plage PLD
If Target.Address = "$H$4" Then Range("J4").Select 'si la cellue modifiée est H4, sélectionne la cellule J4 (saute la somme)
'condition 1 : si le changement a lieu en N4 ou si la ligne 4 contient 13 valeurs
If Target.Address = "$N$4" Or Application.WorksheetFunction.CountA(Rows(Target.Row)) = 13 Then
    If Application.WorksheetFunction.CountA(Rows(Target.Row)) <> 13 Then 'condition 2 : si la ligne 4 ne contient pas 13 valeurs
       If Range("B4").Value = "" Then Range("B4").Select Else Range("B4").End(xlToRight).Offset(0, 1).Select 'sélectionne la cellule vide
       MsgBox "Il manque des données !" 'message
       TEST = False 'reinitialise la variable TEST
       Exit Sub 'sort de la procédure
   Else 'sinon
       TEST = True 'redéfinit la variable TEST
   End If 'fin de la condition 2
   If IsDate(Range("B4").Value) = True Then 'condition 3 : si B4 est une date
       D = CDate(Range("B4").Value) 'définit la date D
   Else 'sinon (si B4 n'est pas une date)
       MsgBox "Date non valide !" 'message
       Range("B4").Select 'sélectionne B4
       TEST = False 'réinitialise la variable TEST
       Exit Sub 'sort de la procédure
   End If 'fin de la condition 3
   M = Format(D, "mmmm") 'définit le mois M
   Set R = Cells.Find(M, , xlValues, xlWhole) 'définit la recherche R (recherche le mois entier dans l'onglet)
   If Not R Is Nothing Then 'condition 4 : si il existe au moins une occurrence trouvée
       Set DEST = IIf(R.Offset(1, 0) = "", R, R.End(xlDown)) 'définit la cellule de destination DEST
       If DEST.Value = "fin" Then 'condition 5 : si DEST vaut "fin"
           Rows(DEST.Row).Insert shift:=xlDown 'insère une ligne au dessus
           Set DEST = DEST.Offset(-1, 0) 'redéfinit DEST une ligne au dessus
       Else 'sinon
           Set DEST = DEST.Offset(1, 0) 'redéfinit DEST une ligne au dessous
       End If 'fin de la condition 5
       PLD.Copy 'copie la plage PLD
       DEST.PasteSpecial (xlPasteAllExceptBorders) 'colle sans les bordures dans DEST
   End If 'fin de la condition 4
   Range("B4:H4,J4:N4").ClearContents 'efface la ligne d'entrée
   Set PL = R.CurrentRegion 'définit la plage PL
   Set PL = PL.Offset(1, 0).Resize(PL.Rows.Count - 2, PL.Columns.Count) 'redéfinit la plage PL (sans la premiere et la derniere ligne)
   'tri du mois
   ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    Sheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(2), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(3), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange PL
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B4").Select 'sélectionne la cellule B4
End If 'fin de la condition 1
fin:     'étiquette
Err.Clear 'efface l'erreur
TEST = False 'réinitialise la variable TEST
End Sub

Sub macro1() 'si le renvoie dans les tableaux de mois ne fonctionne plus, lancer cette macro et retester
TEST = False 'réinitialise la variable TEST
End Sub
Le 05/07/2015 à 11:09

Bonjour

Oui navré j ai un peu honte

Merci beaucoup pour ton aide c est du super boulot

Le 05/07/2015 à 11:27

Ah mince je viens de me rendre compte d un truc dans le code

Si je nomme la feuille 1 "2015"

Ca ne va plus marcher il va falloir que je renomme dans le code

Ca pas de problème mais le code ne s'appliquera pas aux feuilles que j ajouterait dans le classeur pour les années suivantes ("2016" , "2017" , etc )

Je pense qu il vaut mieux mettre le code dans worksheet pour qu il s applique a l ensemble du classeur

Vous n êtes pas d accord ?

Le 05/07/2015 à 13:20

Bonjour Lolotte, bonjour le forum,

Je suis copmplètement d'accord mais pourquoi tu ne testes pas avant de poser la question ?

Le code à placer désormais dans le composant ThisWorkbook :

Private TEST As Boolean 'déclare la variable TEST

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'au changement dans n'importe quel onglet du classeur
Dim PLD As Range 'déclare la varialbe PLD (PLage de Données)
Dim M As String 'déclare la variable M (Mois)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim PL As Range 'déclare la variable PL (PLage)

On Error GoTo fin 'gestion des erreurs, en cas d'erreur va à l'étiquette "fin" (permet à l'événement Change de touner après un plantage)
If TEST = True Then Exit Sub 'si TEST est [Vrai], sort de la procédure
Set PLD = Range("B4:N4") 'définit la plage PLD
If Target.Address = "$H$4" Then Range("J4").Select 'si la cellue modifiée est H4, sélectionne la cellule J4 (saute la somme)
'condition 1 : si le changement a lieu en N4 ou si la ligne 4 contient 13 valeurs
If Target.Address = "$N$4" Or Application.WorksheetFunction.CountA(Rows(Target.Row)) = 13 Then
    If Application.WorksheetFunction.CountA(Rows(Target.Row)) <> 13 Then 'condition 2 : si la ligne 4 ne contient pas 13 valeurs
      If Range("B4").Value = "" Then Range("B4").Select Else Range("B4").End(xlToRight).Offset(0, 1).Select 'sélectionne la cellule vide
      MsgBox "Il manque des données !" 'message
      TEST = False 'reinitialise la variable TEST
      Exit Sub 'sort de la procédure
  Else 'sinon
      TEST = True 'redéfinit la variable TEST
  End If 'fin de la condition 2
  If IsDate(Range("B4").Value) = True Then 'condition 3 : si B4 est une date
      D = CDate(Range("B4").Value) 'définit la date D
  Else 'sinon (si B4 n'est pas une date)
      MsgBox "Date non valide !" 'message
      Range("B4").Select 'sélectionne B4
      TEST = False 'réinitialise la variable TEST
      Exit Sub 'sort de la procédure
  End If 'fin de la condition 3
  M = Format(D, "mmmm") 'définit le mois M
  Set R = Cells.Find(M, , xlValues, xlWhole) 'définit la recherche R (recherche le mois entier dans l'onglet)
  If Not R Is Nothing Then 'condition 4 : si il existe au moins une occurrence trouvée
      Set DEST = IIf(R.Offset(1, 0) = "", R, R.End(xlDown)) 'définit la cellule de destination DEST
      If DEST.Value = "fin" Then 'condition 5 : si DEST vaut "fin"
          Rows(DEST.Row).Insert shift:=xlDown 'insère une ligne au dessus
          Set DEST = DEST.Offset(-1, 0) 'redéfinit DEST une ligne au dessus
      Else 'sinon
          Set DEST = DEST.Offset(1, 0) 'redéfinit DEST une ligne au dessous
      End If 'fin de la condition 5
      PLD.Copy 'copie la plage PLD
      DEST.PasteSpecial (xlPasteAllExceptBorders) 'colle sans les bordures dans DEST
  End If 'fin de la condition 4
  Range("B4:H4,J4:N4").ClearContents 'efface la ligne d'entrée
  Set PL = R.CurrentRegion 'définit la plage PL
  Set PL = PL.Offset(1, 0).Resize(PL.Rows.Count - 2, PL.Columns.Count) 'redéfinit la plage PL (sans la premiere et la derniere ligne)
  'tri du mois
  ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    Sheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(2), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Application.Intersect(Columns(3), PL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange PL
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B4").Select 'sélectionne la cellule B4
End If 'fin de la condition 1
fin:         'étiquette
Err.Clear 'efface l'erreur
TEST = False 'réinitialise la variable TEST
End Sub

Sub macro1() 'si le renvoie dans les tableaux de mois ne fonctionne plus, lancer cette macro et retester
TEST = False 'réinitialise la variable TEST
End Sub
Le 05/07/2015 à 14:49

Oui c est ce que j essayait de faire

Merci pour tout

Rechercher des sujets similaires à "creer zone saisie"