[TOPIC UNIK] VBA et Excel 200x exemples de code

VBA et Excel 200x exemples de code [TOPIC UNIK] - VB/VBA/VBS - Programmation

Marsh Posté le 18-01-2006 à 10:50:03    

Comme pas mal de personnes, j'ai souvent cherché des bouts de code pour faire les programmes en vba.
Donc je souhaite mettre à disposition ces bouts de code pour les débutants comme moi.
 
Je pense que ceci va grandement aider, enfin je crois.
 
Allez je me lance :
 
 
Calcul les totaux de toutes les feuilles sur la feuille « Decompte »

Code :
  1. Sub Totaux()
  2.     Dim i, PrixHT, x
  3.     PrixHT = 0
  4. ‘x represente les cellules D21 a additionner des differentes feuilles
  5.     For x = 21 To 32
  6.     For i = 3 To Worksheets.Count
  7.         If Sheets(i).Range("D" & x).Value = "" Then
  8.         Sheets(i).Range("D" & x).Value = 0
  9.         Else
  10.             PrixHT = PrixHT + Sheets(i).Range("D" & x).Value
  11.             End If
  12.     Next i
  13.     Sheets("Decompte" ).Activate 
  14.     Range("F" & x + 3).Value = PrixHT
  15.     PrixHT = 0
  16. Next x
  17. End Sub


 
Vide les TextBox et décoche les Checkbox de leur contenu
http://img40.imageshack.us/img40/3590/untitled2copy4lv.th.jpg

Code :
  1. ' Vide le contenu des Textbox et Checkbox du formulaire
  2. Sub ViderTextbox()
  3.      For Each Ctrl In UserForm1.Controls
  4.           If TypeOf Ctrl Is MSForms.TextBox Then
  5.                Ctrl.Value = ""
  6.           End If
  7.      Next Ctrl
  8.    
  9.     For Each Ctrl In UserForm1.Controls
  10.           If TypeOf Ctrl Is MSForms.CheckBox Then
  11.                Ctrl.Value = ""
  12.           End If
  13.      Next Ctrl
  14. End Sub


 
Ce code permet d’afficher des valeurs dans une listbox

Code :
  1. Sub ListSociete()
  2. 'liste les differentes sociétés dans la listbox
  3. With UserForm1.ListBoxSociete
  4.                 .AddItem "SARL 1"
  5.                 .AddItem "SARL 2"
  6.                 .AddItem "SARL 3
  7.                 .AddItem "SARL 4"
  8.                 .AddItem "SARL 5"
  9.                 .AddItem "SARL 6"
  10.                 .AddItem "SARL 7"
  11.                 .AddItem "SCI 8"
  12.                 .AddItem "SCI 9"
  13. End With
  14. End Sub


 
Met la date d’aujourd’hui formatée dans TextBox

Code :
  1. UserForm1.TextBoxDate.Value = Format(Now(), "dd/mm/yy" )


 
Met une couleur à une feuille en fonction d’une checkbox
http://img40.imageshack.us/img40/6769/untitled2copy4lg.th.jpg

Code :
  1. Sub CouleurOnglet()
  2. Onglet = ActiveSheet.Name
  3.     If CheckBox1 = False Then
  4.         ActiveWorkbook.Sheets(Onglet).Tab.ColorIndex = 3
  5.     Else
  6.         ActiveWorkbook.Sheets(Onglet).Tab.ColorIndex = 4
  7.     End If
  8. End Sub


 
Recupere les valeurs et les dates des cellules de plusieurs feuilles pour les mettre dans une feuille
http://img6.imageshack.us/img6/489/m3aa1.th.jpg

Code :
  1. Sub Acompte()
  2. Dim i, Acompt, x, y, Dt
  3. x = 1
  4. y = 44
  5.     For i = 3 To Worksheets.Count
  6.         Acompt = 0
  7.         Acompt = Sheets("Situation N°" & x).Range("D40" ).Value
  8.         Dt = Sheets("Situation N°" & x).Range("C14" ).Value
  9.         Sheets("Decompte" ).Activate
  10.         Range("A" & y).Value = Acompt
  11.         Range("B" & y).Value = Dt
  12.         x = x + 1
  13.         y = y + 1
  14.     Next i
  15. End Sub


 
Additionner les valeurs de plusieurs TextBox dans une dernière
http://img6.imageshack.us/img6/4038/m9qw.th.jpg

Code :
  1. Sub TotalAcompte()
  2. With UserForm1
  3.      Dim i As Integer
  4.      MontantTotal = 0
  5.      For i = 1 To 7
  6.           MontantTotal = (MontantTotal + .Controls("TextBoxMontant" & i).Value)
  7.      Next i
  8.      .TextBoxMontantTotal.Value = MontantTotal
  9. End With
  10. End Sub


 
Fait la somme des cellules qui ne sont pas en gras

Code :
  1. Dim i
  2. total = 0
  3. For i = 15 To 30
  4.     If Range("I" & i).Font.Bold = False Then
  5.         total = total + Range("I" & i).Value
  6.     Else
  7.     End If
  8. Next i
  10. Range("J32" ).Value = total


 
Choisir une image et la mettre dans un ctrl image et bloquer le bouton
http://img6.imageshack.us/img6/6199/m1do.th.jpg

Code :
  1. With Application.FileDialog(msoFileDialogFilePicker)
  2.          .AllowMultiSelect = False         'Un seul Fichier possible
  3.          .InitialFileName = "C:\Temp\test\"          'Répertoire d'ouverture de la fenetre
  4.          .Filters.Clear                    'Annuler les filtres au cas où
  5.          .Filters.Add Description:="Images", Extensions:="*.jpg", Position:=1
  6.          .Title = "Choix de l'image"
  7.     'verification au cas ou click sur annul dans la boite + lance la boite
  8.             If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
  9. End With
  11.             'signaler à la personne qu'aucun fichier n'est choisi
  12.             If TheFile = 0 Then
  13.                 MsgBox ("aucun fichier image choisi" )
  14.             'Afficher l'image dans le userform
  15.             Else
  16.                 UserForm1.Image1.Picture = LoadPicture(TheFile)
  17.                 ActiveWindow.Selection.SlideRange.Shapes.AddPicture _
  18.                 (FileName:=TheFile _
  19.                 , LinkToFile:=msoFalse, SaveWithDocument:=msoTrue _
  20.                 , Left:=19, Top:=20, Width:=200, Height:=112.5).Select
  22.                 UserForm1.CommandButton1.Locked = True
  23.             End If


Message édité par sakuraba le 19-01-2006 à 14:02:59

---------------
Newsletter RCZ : inscriptions compliquées ou réceptions tardives ? Mon blog la partage sans délai. C est ici que ça se passe : https://gravelparis.com/
Reply

Marsh Posté le 18-01-2006 à 10:50:03   

Reply

Marsh Posté le 19-01-2006 à 10:00:08    

Salut à tous !
Très bonne idée ce topik sakuraba ! Peut-être pourrait-on l'étendre à excel 2002. Dans ce cas là, je posterais volontier quelques bouts de codes simple et commentés :)
@+


---------------
Je bidouillle c'est sur... Mais j'essaye de faire en sorte que ça marche ;-)
Reply

Marsh Posté le 19-01-2006 à 13:53:50    

oui bien sûr.
 
je corrige

Reply

Marsh Posté le 23-01-2006 à 16:30:44    

Bon ben en route alors !
 
Voilà quelques boûts de codes autours de Filedialog qui permettent :
 
Faire sélectionner un fichier xls :

Code :
  1. Sub ChoixFichier()
  2. 'macro de choix d'un fichier
  3.      Dim CheminFichier As FileDialog
  4.      Set CheminFichier = Application.FileDialog(msoFileDialogFilePicker)
  5.      With CheminFichier
  6.           .AllowMultiSelect = False
  7.           .InitialFileName = "C:\"
  8.           .Filters.Clear
  9.           .Filters.Add Description:="Microsoft Excel", Extensions:="*.xls", Position:=1
  10.           .Title = "Choix d'un fichier"
  11.           'La variable Fichier est déclarée en entête de module
  12.            If .Show = -1 Then Fichier = .SelectedItems(1) Else Fichier = 0
  13.      End With
  14.      ' En cas d'annulation Fichier = 0
  15. End Sub


Faire sélectioner un dossier :

Code :
  1. Sub ChoixDossier()
  2.      Dim Dossier As FileDialog
  3.      Set Dossier = Application.FileDialog(msoFileDialogFolderPicker)
  4.      With Dossier
  5.           .AllowMultiSelect = False
  6.           .InitialFileName = "C:\"
  7.           .Title = "Choix d'un dossier"
  8.           'La variable Chemin est déclarée en entête de module
  9.           If .Show = -1 Then chemin = .SelectedItems(1) & "\" Else chemin = 0
  10.      End With
  11. End Sub


Etablir la liste des classeurs Xls dans un dossier selectioné :

Code :
  1. Sub ListeFichier()
  2.      Dim i, chemin
  3.      Dim Dossier As FileDialog
  4. 'Choix du dossier
  5.      Set Dossier = Application.FileDialog(msoFileDialogFolderPicker)
  6.      With Dossier
  7.           .AllowMultiSelect = False
  8.           .InitialFileName = "C:\"
  9.           .Title = "Choix d'un dossier"
  10.           If .Show = -1 Then
  11.                chemin = .SelectedItems(1) & "\"
  12. 'mise en place de la liste de fichier
  13.                With Application.FileSearch
  14.                     .NewSearch
  15.                     .FileType = msoFileTypeExcelWorkbooks
  16.                     .SearchSubFolders = False
  17.                     .LookIn = chemin
  18.                     If .Execute() > 0 Then
  19.                          ReDim Preserve LFichier(.FoundFiles.Count - 1)
  20.                          For i = 1 To .FoundFiles.Count
  21.           'La variable LFichier() est déclarée en variant en entête de module
  22.                               LFichier(i - 1) = .FoundFiles(i)
  23.                          Next i
  24.                     Else
  25.                          MsgBox ("Aucun fichier trouvé" )
  26.                          chemin = ""
  27.                     End If
  28.                End With
  29.           Else: chemin = 0
  30.           End If
  31.      End With
  32. End Sub


 
@+


---------------
Je bidouillle c'est sur... Mais j'essaye de faire en sorte que ça marche ;-)
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed