Macro excel

missnour -  
Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,
je souhaiterais effectuer une selection variable dune plage de cellule en fonction de la date (si la date arrivent dans 15 jours) faire extraire les donne ver une autre feuil voila le code aide moi svp
Option Explicit

Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le le 13/03/2009 par chemaa
'

'
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Range("H").Select
Selection.Interior.ColorIndex = xlNone
End Sub
Option Explicit
Private Sub Workbook_Open()
Dim DerLig As Long, Lig As Long, NbJ As Integer
Dim DateF As Date, DateJ As Date
Dim NumLig As Long
Dim Col As String
Dim NbrLig As Long
Dim Msg As String
' récupérer le nombre de jour avant échéance
NbJ = Sheets("Params").Range("NbJAvt").Value
DateJ = Format(Now() + NbJ, "dd/mm/yyyy")
Msg = ""
' Avec Etat Inter 28janv09
With Sheets("Etat Inter 28janv09")
' Récupérer la dernière ligne du tableau
DerLig = .Range("G" & Rows.Count).End(xlUp).Row
' Pour chaque ligne on vérifie si écchéance proche
For Lig = 2 To DerLig
' Récupérer la date de la feuille colonne H
On Error Resume Next
DateF = Format(.Range("H" & Lig).Value, "dd/mm/yyyy")
On Error GoTo 0
' Vérifier avec la Date du Jour d'échéance + Nb jours d'avance
If DateF = DateJ Then
Msg = Msg & Lig & ", "
' Mettre en rouge (par exemple) la cellule
.Range("H" & Lig).Interior.ColorIndex = 3
End If
Next Lig
End With

Sheets("Feuil1").Activate ' feuille de destination

Col = "H" ' colonne de la donnée non vide à tester
NumLig = 0
With Sheets("Etat Inter 28janv09") ' feuille source
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 1 To NbrLig
If .Cells(Lig, Col).Value <> "" Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Cells(NumLig, 1).Select
ActiveSheet.Paste
End If
Next
End With

End Sub
Configuration: Windows XP
Internet Explorer 6.0

12 réponses

  1.
    Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour,
    Ou est le problème, la macro fonctionne.
    0
    1. missnour
       
      Essayer de maidé stp c trés inport
      0
  2. missnour
     
    slt,d'abord merci pour votre attention
    le probléme c ke je veux :
    -Je veux que l’algorithme me créer une nouvelle feuil a chaque exécution

    Set mafeuille = Sheets.Add(, Sheets(Sheets.Count))
    mafeuille.Name = "Feuil1"

    - cherché les date arivent a la fin apré 15 jours

    Private Sub Workbook_Open()
    Dim DerLig As Long, Lig As Long, NbJ As Integer
    Dim DateF As Date, DateJ As Date
    Dim Msg As String
    ' récupérer le nombre de jour avant échéance
    NbJ = Sheets("Params").Range("NbJAvt").Value
    DateJ = Format(Now() + NbJ, "dd/mm/yyyy")
    Msg = ""
    ' Avec Etat Inter 28janv09
    With Sheets("Etat Inter 28janv09")
    ' Récupérer la dernière ligne du tableau
    DerLig = .Range("G" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne on vérifie si écchéance proche
    For Lig = 2 To DerLig
    ' Récupérer la date de la feuille colonne C
    On Error Resume Next
    DateF = Format(.Range("H" & Lig).Value, "dd/mm/yyyy")
    On Error GoTo 0
    ' Vérifier avec la Date du Jour d'échéance + Nb jours d'avance
    If DateF = DateJ Then
    Msg = Msg & Lig & ", "
    ' Mettre en rouge (par exemple) la cellule
    .Range("H" & Lig).Interior.ColorIndex = 3
    End If
    Next Lig
    End With
    If Msg <> "" Then
    ' Supprimer la virgule de la fin
    Msg = Left(Msg, Len(Msg) - 2)
    ' Afficher le message
    MsgBox "Attention, les lignes : " & Msg & " arrivent à la fin du contart dans : " & NbJ & " jour(s)"
    End If
    End Sub
    Je veux pas avoir un message je veux avoir le résultat dans la nouvelle feuil crées déjà
    -pour copie les donnée d 'une feuil a une autre (copie juste les resultat de l’algorithme précèdent

    Sheets("Etat Inter 28janv09").Select
    ActiveCell.SpecialCells(xlLastCell).Select
    Range(Selection, Cells(1)).Select
    Sheets("Feuil1").Activate ' feuille de destination
    Col = "H" ' colonne de la donnée non vide à tester
    NumLig = 0
    With Sheets("Etat Inter 28janv09") ' feuille source
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig
    If .Cells(Lig, Col).Value <> "" Then
    .Cells(Lig, Col).EntireRow.Copy
    NumLig = NumLig + 1
    Cells(NumLig, 1).Select
    ActiveSheet.Paste
    End If
    Next
    End With
    0
  3. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour missnour,
    Je commence à comprendre se que vous désirez obtenir.
    Par contre pour intervenir correctement dans votre macro il serait bien de connaitre la structure du classeur, au minimum la feuille qui contient les données que vous voulez copier vers une autre feuille.

    0
  4. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour missnour,
    Si je comprend bien, vous désirez que toutes les échéances trouvées soient extraite sur la nouvelle feuille !
    0
    1. missnour
       
      Exactement
      la feuil source Etat inter 28janv09
      la feuil qui fai la reception des donné trouvé c la feuil crée (feuil1)
      0
      1. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478 > missnour
         
        Bonjour missnour,
        Essayez avec la macro ci dessous.
        La coller dans le même module et renommer l'ancienne par : Private Sub Workbook_Open_old()
        pour la neutraliser. 
        Private Sub Workbook_Open()
Dim DerLig As Long, Lig As Long, NbJ As Integer, shli As Integer
Dim DateF As Date, DateJ As Date
Dim Msg As String, shEch As String
' récupérer le nombre de jour avant échéance
NbJ = Sheets("Params").Range("NbJAvt").Value
DateJ = Format(Now() + NbJ, "dd/mm/yyyy")
Msg = ""
shEch = ""
' Avec Etat Inter 28janv09
With Sheets("Etat Inter 28janv09")
' Récupérer la dernière ligne du tableau
DerLig = .Range("G" & Rows.Count).End(xlUp).Row
' Pour chaque ligne on vérifie si écchéance proche
For Lig = 2 To DerLig
' Récupérer la date de la feuille colonne C
On Error Resume Next
DateF = Format(.Range("g" & Lig).Value, "dd/mm/yyyy")
On Error GoTo 0
' Vérifier avec la Date du Jour d'échéance + Nb jours d'avance
If DateF = DateJ Then
' **** au premier passage créer la nouvelle feuille et la nommer
    If shEch = "" Then
        Set mafeuille = Sheets.Add(, Sheets(Sheets.Count))
        mafeuille.Name = "Echeance_" & DateJ
        shEch = ActiveSheet.Name
        Sheets("Etat Inter 28janv09").Rows(1).Copy Destination:=Rows(1)
        shli = 2
        Sheets("Etat Inter 28janv09").Select
    End If
 ' **** copier la ligne vers nouvelle feuille
    Rows(Lig).Copy Destination:=Sheets(shEch).Rows(shli)
    shli = shli + 1
'***Msg = Msg & Lig & ", "
'***Mettre en rouge (par exemple) la cellule
'***.Range("H" & Lig).Interior.ColorIndex = 3
End If
        --

        Salutations.
        Jean-Pierre
        0
      2. missnour > Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention  
         
        j ai un probléme tu peux me contacté sur mon email c chemaaf.z@hotmail.com j atend ta reponse merci d'avance
        0
      3. missnour > missnour
         
        re bjr
        acune resulta donnée
        0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour,
    Qu'elle est le problème !
    0
  7. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour missnour,
    Trouver cette ligne dans la macro:
    DateF = Format(.Range("g" & Lig).Value, "dd/mm/yyyy")

    Remplacer le "g" par "H" .... eh oui, sans la structure de votre feuille .....
    0
    1. missnour
       
      meme si j ai déjat modifier G par H mais rien a signaler
      0
  8. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour,
    Quel résultat obtenez-vous avec la macro non modifié ?
    Merci de votre réponse.
    0
    1. missnour
       
      slt
      mon premier macro il colore en rouge les date concerné il insere une nouvel feuil il fait copie de tou le tableau non pas juste les gents arivent a la fin
      0
  9. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour,
    Merci de m'envoyer cette macro qui fonctionne !
    J'attends ..
    0
    1. missnour
       
      je veux annulé la fichage du message
      ce ke je veux ajouté a mon macro
      -inserér une feuil
      -copie les resultats dans la nouvel feuil
      0
  10. missnour
     
    Private Sub Workbook_Open()
    Dim DerLig As Long, Lig As Long, NbJ As Integer
    Dim DateF As Date, DateJ As Date
    Dim NumLig As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim Msg As String
    ' récupérer le nombre de jour avant échéance
    NbJ = Sheets("Params").Range("NbJAvt").Value
    DateJ = Format(Now() + NbJ, "dd/mm/yyyy")
    Msg = ""
    ' Avec Etat Inter 28janv09
    With Sheets("Etat Inter 28janv09")
    ' Récupérer la dernière ligne du tableau
    DerLig = .Range("G" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne on vérifie si écchéance proche
    For Lig = 2 To DerLig
    ' Récupérer la date de la feuille colonne H
    On Error Resume Next
    DateF = Format(.Range("H" & Lig).Value, "dd/mm/yyyy")
    On Error GoTo 0
    ' Vérifier avec la Date du Jour d'échéance + Nb jours d'avance
    If DateF = DateJ Then
    Msg = Msg & Lig & ", "
    ' Mettre en rouge (par exemple) la cellule
    .Range("H" & Lig).Interior.ColorIndex = 3
    End If
    Next Lig
    End With

    Sheets("Feuil1").Activate ' feuille de destination

    Col = "H" ' colonne de la donnée non vide à tester
    NumLig = 0
    With Sheets("Etat Inter 28janv09") ' feuille source
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig
    If .Cells(Lig, Col).Value <> "" Then
    .Cells(Lig, Col).EntireRow.Copy
    NumLig = NumLig + 1
    Cells(NumLig, 1).Select
    ActiveSheet.Paste
    End If
    Next
    End With

    End Sub
    0
  11. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour missnour,
    Une bonne nouvel et une mauvaise.
    Les 2 macros fonctionnent correctement, donc le problème est chez vous.
    Je vous joint une nouvel copie du code qui fonctionne chez moi.
    Vous devez le copiez dans votre [ThisWorkbook] et modifier le nom de l'autre macro pour a neutraliser. 
    Private Sub Workbook_Open()
Dim DerLig As Long, Lig As Long, NbJ As Integer, shli As Integer
Dim DateF As Date, DateJ As Date
Dim Msg As String, shEch As String
' récupérer le nombre de jour avant échéance
NbJ = Sheets("Params").Range("NbJAvt").Value
DateJ = Format(Now() + NbJ, "dd/mm/yyyy")
Msg = ""
shEch = ""
' Avec Etat Inter 28janv09
With Sheets("Etat Inter 28janv09")
' Récupérer la dernière ligne du tableau
DerLig = .Range("G" & Rows.Count).End(xlUp).Row
' Pour chaque ligne on vérifie si écchéance proche
For Lig = 2 To DerLig
' Récupérer la date de la feuille colonne C
On Error Resume Next
DateF = Format(.Range("H" & Lig).Value, "dd/mm/yyyy")
On Error GoTo 0
' Vérifier avec la Date du Jour d'échéance + Nb jours d'avance
If DateF = DateJ Then
' **** au premier passage créer la nouvelle feuille et la nommer
    If shEch = "" Then
        Set mafeuille = Sheets.Add(, Sheets(Sheets.Count))
        mafeuille.Name = "Echeance_" & DateJ
        shEch = ActiveSheet.Name
        Sheets("Etat Inter 28janv09").Rows(1).Copy Destination:=Rows(1)
        shli = 2
        Sheets("Etat Inter 28janv09").Select
    End If
 ' **** copier la ligne vers nouvelle feuille
    Rows(Lig).Copy Destination:=Sheets(shEch).Rows(shli)
    shli = shli + 1
'***Msg = Msg & Lig & ", "
'***Mettre en rouge (par exemple) la cellule
'***.Range("H" & Lig).Interior.ColorIndex = 3
End If
Next Lig
End With
' ***If Msg <> "" Then
' Supprimer la virgule de la fin
' ***Msg = Left(Msg, Len(Msg) - 2)
' Afficher le message
' ***MsgBox "Attention, les lignes : " & Msg & " arrivent à la fin du contart dans : " & NbJ & " jour(s)"
' ***End If
End Sub


    Note: vous constaterez que les messages non désirés sont neutralisés !
    Petit détail, votre macro ne crée aucune nouvelle feuille, au contraire, de la modifier qui crée une feuille nommées Echeance_+ la date d'échéance.
    0
    1. missnour
       
      il me donne erreur d'execution '1004'
      erreure définie par l'application ou par l'objet
      0
      1. missnour > missnour
         
        ok je vais esayer de resoudre se prob, autre chose peu tu me renseigner sur access
        j ai un autre code vb est je veux l'utiliser dans une basse de donnée access vb6-vba (chiffre en lettre) par exemple quant je tappe 5000 dh dans le champ salaire,je doi avoir cinq mile dirhams dans l'autre champ(salaire en lettres)
        le probléme c que jai déja fai copie coller de se code dans modules mais je connai pas l'astuce pr créer une macro pr activer le macro dans les champs concernér
        merci
        0
      2. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478 > missnour
         
        Bonjour,
        Pour l'erreur, merci d'indiquer la ligne de code surlignée en jaune !
        0
  12. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour,
    Pour ceci : le probléme c que jai déja fai copie coller de se code dans modules mais je connai pas l'astuce pr créer une macro pr activer le macro dans les champs concernér
    C'est incompréhensible !
    0
    1. missnour
       
      Pour ceci : le probléme c que jai déja fai copie coller de se code dans modules mais je connai pas l'astuce pr créer une macro pr activer le macro dans les champs concernér
      je veux crées un macro pr executé le code vb qui setrouve dans le module
      je veux meme savoir comme faire pr spesifier que ce macro doi sexsecuté juste apre la sesie du salaire en chiffre
      0
  13. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    Bonjour,
    Désolé, mais je pense qu'il s'agit d'un autre problème que je n'arrive pas à comprendre, je ne suis pas Mme Soleil.
    0

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses