Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Un bon livre pour amélioration code VBA adressé à mapomme et autres personnes trés compétentes

JBARBE

XLDnaute Barbatruc
Bonjour mapomme, bonjour le forum,

J'ai toujours été en extase devant le travail accompli en VBA sur ce site par des personnes comme mapomme !

Je prends comme exemple la macro qu'il a faite ici :

__________________________________________________________________________


http://excel-downloads.com/threads/problème-à-résolutions-successives.20010922/page-2

Option Explicit

Sub ValCol()

Const FirstTournementColumn = "J" ' lettre de la première colonne des tournois

Dim ColDeb&, ColFin&, ligdeb&, ligfin&, k&, l&, topinit
Dim V(), C(), N, Dmin As Date, aux, s, xrg As Range
Dim auxTab(), tmpTab, i&, j&, plage As Range

On Error GoTo FIN 'en cas d'erreur, on réactive la détection des évènements
Application.EnableEvents = False

topinit = Timer
Application.ScreenUpdating = False
ColDeb = Range(FirstTournementColumn & "1").Column 'début des données (ligne)
ColFin = Cells(2, Columns.Count).End(xlToLeft).Column 'fin des données (ligne)
ligdeb = 4 'début des données (colonne)
ligfin = Cells(Rows.Count, "a").End(xlUp).Row 'fin des données (colonne)
Dmin = DateSerial(Year(Date) - 2, Month(Date), Day(Date)) 'Date lumite
N = ColFin - ColDeb + 1 'nombre de colonnes
ReDim V(1 To N): ReDim C(1 To N) ' création des tableaux des valeurs
' et des n° de colonnes associés
ReDim auxTab(ligdeb To ligfin, 1 To 2) ' création d'un tableau auxilliaire 'auxTab'


' -------------------------------------------------------------------------------------
' | MFC des premières colonnes |
' -------------------------------------------------------------------------------------
With Range(Cells(ligdeb, "a"), Cells(ligfin, "g"))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(SOMMEPROD(--($B$3:$B3<>$B$4:$B4));2)=1"
.FormatConditions(1).SetFirstPriority
.FormatConditions(1).Interior.Color = RGB(246, 255, 194)
.FormatConditions(1).StopIfTrue = False
End With


' -------------------------------------------------------------------------------------
' | traitement des colonnes des tournois |
' -------------------------------------------------------------------------------------

' on efface la couleur de fond des colonnes de tournois
Range(Cells(ligdeb, ColDeb), Cells(ligfin, ColFin)).Interior.ColorIndex = xlColorIndexNone
Application.ScreenUpdating = False

For k = ligdeb To ligfin
Set xrg = Range(Cells(k, ColDeb), Cells(k, ColFin)) 'range de la ligne en cours

For l = 1 To N 'boucle de remplissage des tableaux V et C
V(l) = 0 + xrg(1, l).Value
C(l) = 0 + xrg(1, l).Column
' si la date est postérieure à la date limite, V(j) est mis à 0
If xrg.Offset(2 - xrg.Row)(l) <= Dmin Then V(l) = 0
Next l

Do ' boucle pour trier v() du plus grand au plus petit (C suit le tri)
aux = False
For l = 1 To N - 1
If V(l) < V(l + 1) Then
aux = V(l): V(l) = V(l + 1): V(l + 1) = aux
aux = C(l): C(l) = C(l + 1): C(l + 1) = aux
aux = True
End If
Next l
Loop Until Not aux

s = 0: For l = 1 To 4: s = s + V(l): Next l 'somme des quatre plus grandes valeurs
auxTab(k, 1) = s 'écriture de cette somme dans le tableau
auxTab(k, 2) = s / 4 'écriture de la somme /4 dans le tableau
For l = 1 To 4 'coloration des cellules
' uniquement si la valeur associée n'est pas nulle
If V(l) > 0 Then Cells(k, C(l)).Interior.Color = RGB(255, 255, 144)
Next l
Next k

'écriture du tableau auxTab sur la feuille
Cells(ligdeb, ColDeb - 2).Resize(ligfin - ligdeb + 1, 2) = auxTab
ActiveSheet.Shapes("bouton").Fill.ForeColor.RGB = RGB(0, 0, 255)


' -------------------------------------------------------------------------------------
' | traitement des catégories d'âges |
' -------------------------------------------------------------------------------------

' lecture de la colonne des dates de naissance (attention! ligne 807 date fausse)
auxTab = Range(Cells(ligdeb, "g"), Cells(ligfin, "g")).Value
' lecture de la colonne des sexes
tmpTab = Range(Cells(ligdeb, "a"), Cells(ligfin, "a")).Value

For i = 1 To UBound(auxTab)
auxTab(i, 1) = tmpTab(i, 1) & categ(auxTab(i, 1))
Next i
Cells(ligdeb, "b").Resize(UBound(auxTab)) = auxTab


' -------------------------------------------------------------------------------------
' | traitement des positions |
' -------------------------------------------------------------------------------------
Dim tcat, tpos, tsco, Points, nIdem&
' tri de toutes les données
Set plage = Range(Cells(ligdeb, "a"), Cells(ligfin, ColFin))
plage.Sort key1:=Columns("b:b"), order1:=xlAscending, _
key2:=Columns("I:I"), order2:=xlDescending, _
Header:=xlNo

'tableau des points, des catégories, des scores
tcat = plage.Columns("B:B").Value
tpos = plage.Columns("C:C").Value
tsco = plage.Columns("I:I").Value

tpos(1, 1) = 1: nIdem = 1
For i = 2 To UBound(auxTab)
If tcat(i, 1) = tcat(i - 1, 1) Then
' même catégorie
If tsco(i, 1) = tsco(i - 1, 1) Then
' même cat , même valeur de points
tpos(i, 1) = tpos(i - 1, 1)
nIdem = nIdem + 1
Else
' même cat , les valeurs de points diffèrent
tpos(i, 1) = tpos(i - 1, 1) + nIdem
nIdem = 1
End If
Else
' la catégorie a changé
tpos(i, 1) = 1
nIdem = 1
End If
Next i
Range("c4").Resize(UBound(tpos)) = tpos


' -------------------------------------------------------------------------------------
' | traitement de fin de procédure |
' -------------------------------------------------------------------------------------

'MsgBox Format(Timer - topinit, "0.00\sec.")
Application.EnableEvents = True
Exit Sub

FIN:
Application.EnableEvents = True
MsgBox "Error n° " & Err.Number & " : " & Err.Description
End Sub

Sub AjoutJoueur()

Application.EnableEvents = False
Application.ScreenUpdating = False
On Error GoTo FIN
UserForm1.Show
Application.EnableEvents = True
Exit Sub

FIN:
Application.EnableEvents = True
End Sub

Sub AjoutTournoi()

On Error GoTo FIN:
Application.EnableEvents = False
Application.ScreenUpdating = False
Cells(1, Columns.Count).Delete 'pour s'assurer qu'il y a de la place pour insérer
Range("j:j").Insert xlShiftToRight, xlFormatFromRightOrBelow
Range("j:j").Interior.ColorIndex = xlColorIndexNone
Application.Goto Range("a1")
Range("j3").Select
MsgBox "Please, enter the values of the new tournament into column J."
Application.EnableEvents = True
Exit Sub
FIN:

Application.EnableEvents = True
MsgBox "An error occurs during the process to insert of a new tournament process." & vbLf & _
vbLf & "Error n° " & Err.Number & ": " & Err.Description
End Sub

__________________________________________________________________________
J'arrive à comprendre certaines lignes mais pour le reste c'est trés difficile !
Cette macro a la particularité de fonctionner trés vite par rapport à ce que j'ai présenté sur ce post !

Ainsi, mes bouquins VBA étant devenu obsolète, je demande à une personne comprenant cette macro ( bien sûr mapomme en fait partie ) de bien vouloir m'indiquer un bouquin VBA se rapportant à ce genre de programmation !

Ces bouquins qui m'ont appris la programmation sont :
programmation et algorithmique en VBA pour excel ( dunod)
programmation VBA pour excel 2007 pour les nuls (John Wakenbach)
VBA Excel 2003 - 2000 (Micro Application )

Cela me permettra d'améliorer mon VBA sur mes fichiers Excel crée et de satisfaire mon plaisir Excel !

ATTENTION : Ne pas me donner une référence avec une programmation trop simple à comprendre car j'ai eu ces notions avec ms anciens bouquins !

Merci à l'avance !
 
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…