Sujet Précédent Sujet Suivant

Macro excel

missnour -  
Le Pingou Messages postés 12713 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
A voir également:

12 réponses

Réponse 1 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
Bonjour,
Ou est le problème, la macro fonctionne.
0
missnour
 
Essayer de maidé stp c trés inport
0
Réponse 2 / 12
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
Réponse 3 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
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
Réponse 4 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
Bonjour missnour,
Si je comprend bien, vous désirez que toutes les échéances trouvées soient extraite sur la nouvelle feuille !
0
missnour
 
Exactement
la feuil source Etat inter 28janv09
la feuil qui fai la reception des donné trouvé c la feuil crée (feuil1)
0
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467 > 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
missnour > Le Pingou Messages postés 12713 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
missnour > missnour
 
re bjr
acune resulta donnée
0

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

Posez votre question
Réponse 5 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
Bonjour,
Qu'elle est le problème !
0
Réponse 6 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
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
missnour
 
meme si j ai déjat modifier G par H mais rien a signaler
0
Réponse 7 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
Bonjour,
Quel résultat obtenez-vous avec la macro non modifié ?
Merci de votre réponse.
0
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
Réponse 8 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
Bonjour,
Merci de m'envoyer cette macro qui fonctionne !
J'attends ..
0
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
Réponse 9 / 12
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
Réponse 10 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
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
missnour
 
il me donne erreur d'execution '1004'
erreure définie par l'application ou par l'objet
0
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
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467 > missnour
 
Bonjour,
Pour l'erreur, merci d'indiquer la ligne de code surlignée en jaune !
0
Réponse 11 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
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
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
Réponse 12 / 12
Le Pingou Messages postés 12713 Date d'inscription   Statut Contributeur Dernière intervention   1 467
 
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