Fabrice.info - Programmation Excel par Fabrice Levasseur

		> Bottom	>> Home

Programmation Excel
Cette page contient des exemples de programmation Visual Basic pour Excel (macro). Ce code est mis en ligne dans la seul but de montrer du code source qui fonctionne et peut donc servir d'exemple au niveau syntaxe.
exemple 1 exemple 2 exemple 3 exemple 4

Exemple 1 : compterTests

Top

Sub compterTests()

'
' compterTests Macro
' Macro enregistrée le 12/02/2004 par Fabrice Levasseur
'
' Contraintes macro 'compterTests' (nombre de tests à partir des copies de DTV)
' -----------------------------------------------------------------------------
'
' 1) pour chaque onglet, le nombre de tests est calculé sur exécution de la macro 'compterTests'
' cette exécution n'est pas automatique : il faut taper le raccourci + q pour l'exécuter
'
' 2) le résultat de cette macro est toujours mis dans la cellule D2 (si cette cellule contient une autre info, il y aura écrasement !)
'
' 3) la colonne B de chaque onglet est INTÉGRALEMENT dédiée à la macro
' => si une valeur numérique non barrée est rajoutée dans cette colonne, cela impactera le résultat de la macro
'
' Parcours de la colonne des tests (B) : de 1 à ligneCMax
ligneNbTestsMax = 5000
' Numero de la colonne à parcourir (colonne des tests : B)
colonneTests = 2

' Compteur de numero de tests valides (numerique et non barré)
compteurTest = 0

'Boucle sur la colonne colonneTests
For ligneC = 1 To ligneNbTestsMax Step 1

' On recupere la valeur de la cellule (ligneC,colonneTests)
Cells(ligneC, colonneTests).Select
valeurC = ActiveCell.Value

' Test valeur numerique
If ((valeurC <> "") And (IsNumeric(valeurC))) Then
' Valeur numerique => test si barrée ou non
If (Selection.Font.Strikethrough = True) Then
' Valeur numerique barree => on colorie le fond seulement
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Else
' Valeur numerique NON barree => on incremente le compteur de tests
compteurTest = compteurTest + 1
Selection.Interior.ColorIndex = xlNone
End If
End If
Next ligneC

' on ecrit le resultat dans la cellule D2 dédiée
Range("D2").Select
ActiveCell.Value = compteurTest
End Sub

Exemple 2 : relanceCats

Top

Sub auto_open()
creerListeDestinataires
End Sub
Sub creerListeDestinataires()
'
' creerListeMails
' Macro enregistrée le 05/12/2003 par Fabrice LEVASSEUR
'
' Récupération du nombre de Collaborateurs (NbC)
NbC = Range("H1").Value

' Boucle sur les NbC
For compteurC = 1 To NbC Step 1
' Collaborateur à ignorer ?
If Cells(compteurC + 1, 4).Value = True Then
Cells(compteurC + 1, 6).Select
ActiveCell.Value = "IGNORE"
Else
' Construction du fichier à contrôler
numSemaine = Range("J8").Value
Cells(compteurC + 1, 2).Select
matriculeC = ActiveCell.Value
complementSemaine = ""
If numSemaine < 10 Then
complementSemaine = "0"
End If

Set wb = ActiveWorkbook
ActivePath = Left(wb.FullName, Len(wb.FullName) - Len(ActiveWorkbook.Name))
cheminFichier = ActivePath & "S" & complementSemaine & numSemaine & "\*_" & matriculeC & ".xls"

Cells(compteurC + 1, 6).Select
If Dir(cheminFichier) = "" Then
ActiveCell.Value = "CATS ABSENT !"
Else
ActiveCell.Value = "CATS présent"
End If
End If

Next compteurC

' On range le curseur (gênant lorsque liste collaborateurs longue)
'Range("J1").Select
End Sub
Sub envoyerMail()
' Création de la liste des detinataires
dest = ""

' Récupération du nombre de Collaborateurs (NbC)
NbC = Range("H1").Value

' Boucle sur les NbC
For compteurC = 1 To NbC Step 1
' CATS absent ?
Cells(compteurC + 1, 6).Select
resultatControle = ActiveCell.Value

If resultatControle = "CATS ABSENT !" Then
Cells(compteurC + 1, 3).Select
mailC = ActiveCell.Value
If dest <> "" Then
dest = dest & " ; "
End If
dest = dest & mailC
End If
Next compteurC

' Envoi du mail
If dest <> "" Then
' Recuperation du type de messagerie
' L7 = 1 (Outlook Express) ou 2 (Outlook 2000)
typeclient = Range("L7").Value

If (typeclient = 1) Then
'Outlook Express
sujet = Range("L2").Value
Texte = Range("L5").Value
Shell "C:\Program Files\Outlook Express\msimn.exe " & "/mailurl:mailto:" & dest & "?subject=" & sujet & "&Body=" & Texte
'pas de confirmation car envoi manuel
Else
' Outlook 2000
Set ol = CreateObject("outlook.application")
Set mail = ol.createitem(olmailitem)
mail.to = dest
mail.Subject = Range("L2").Value
mail.body = Range("L5").Value
mail.send
'confirmation car envoyé automatiquement
MsgBox ("Relance envoyée à : " & dest)
End If
Else
MsgBox ("Tous les CATS sont présents : relance non effectuée")
End If
End Sub

Exemple 3 : TdB

Top

Top

Exemple 4 : traiterCongésCollaborateurs

Top

Top


Copyright © 1998-2012 www.Fabrice.info		> Top	>> Home