With Cells(lg1, cl1)
et End With
étaient inutiles ; je les ai supprimés, puis à la place de Cells(lg2, cl2) = .Value
j'ai mis directement : Cells(lg2, cl2) = Cells(lg1, cl1)
; même utilisation qu'avant ; et mêmes résultats. Option Explicit
Private Sub Job(k As Byte)
Dim cl1 As Byte, lg1&, dlA&
Dim cl2 As Byte, lg2 As Byte, dlB As Byte
Dim dcB As Byte, lgA As Byte, lgB As Byte
If k = 1 Then 'pour les professeurs
cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 5: dlB = 13: dcB = 34
Else 'pour les remplaçants
cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 29: dlB = 37: dcB = 23
End If
lgA =...
Option Explicit
Sub Essai()
Dim cl1 As Byte, lg1&, cl2 As Byte, lg2 As Byte, vx%
cl1 = 5: lg1 = 2: cl2 = 17: lg2 = 2: Application.ScreenUpdating = 0
Do
With Cells(lg1, cl1)
If IsEmpty(.Value) Then
lg1 = 2: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub
End If
vx = .Value: lg1 = lg1 + 1: Cells(lg2, cl2) = vx: lg2 = lg2 + 1
If lg2 = 11 Then lg2 = 2: cl2 = cl2 + 1
If cl2 = 25 Then Exit Sub
End With
Loop
End Sub
=DECALER($E$2;9*(COLONNE(Q1)-COLONNE($Q$1))+(LIGNE(Q1)-LIGNE($Q$1));0)
bonjourBonjour Seddiki,
fais Ctrl e ➯ travail effectué !
code VBA (17 lignes) :
VB:Option Explicit Sub Essai() Dim cl1 As Byte, lg1&, cl2 As Byte, lg2 As Byte, vx% cl1 = 5: lg1 = 2: cl2 = 17: lg2 = 2: Application.ScreenUpdating = 0 Do With Cells(lg1, cl1) If IsEmpty(.Value) Then lg1 = 2: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub End If vx = .Value: lg1 = lg1 + 1: Cells(lg2, cl2) = vx: lg2 = lg2 + 1 If lg2 = 11 Then lg2 = 2: cl2 = cl2 + 1 If cl2 = 25 Then Exit Sub End With Loop End Sub
soan
bonjourBonjour,
Une autre proposition :
Code:=DECALER($E$2;9*(COLONNE(Q1)-COLONNE($Q$1))+(LIGNE(Q1)-LIGNE($Q$1));0)
Option Explicit
Sub Essai()
Dim cl1 As Byte, lg1&, cl2 As Byte, lg2 As Byte
cl1 = 5: lg1 = 2: cl2 = 17: lg2 = 2: Application.ScreenUpdating = 0
Do
With Cells(lg1, cl1)
If IsEmpty(.Value) Then
lg1 = 2: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub
End If
lg1 = lg1 + 1: Cells(lg2, cl2) = .Value: lg2 = lg2 + 1
If lg2 = 11 Then lg2 = 2: cl2 = cl2 + 1
If cl2 = 25 Then Exit Sub
End With
Loop
End Sub
Merci Soan@Seddiki (salut Marcel)
j'avais utilisé la variable vx, mais en fait, c'était inutile ; j'ai donc optimisé le code vba en supprimant cette variable vx ; le code vba fait toujours 17 lignes.
VB:Option Explicit Sub Essai() Dim cl1 As Byte, lg1&, cl2 As Byte, lg2 As Byte cl1 = 5: lg1 = 2: cl2 = 17: lg2 = 2: Application.ScreenUpdating = 0 Do With Cells(lg1, cl1) If IsEmpty(.Value) Then lg1 = 2: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub End If lg1 = lg1 + 1: Cells(lg2, cl2) = .Value: lg2 = lg2 + 1 If lg2 = 11 Then lg2 = 2: cl2 = cl2 + 1 If cl2 = 25 Then Exit Sub End With Loop End Sub
résultat de ce 2ème code vba (identique à celui du 1er code vba) :
Regarde la pièce jointe 1140710
soan
Oui je te comprend les donnes sera varie suivant le nombre de salle et le nombre des profs je fais cette exemple pour préparer je veut et si possible d'ajouter comment obtenir les remplaçants?@Seddiki
* les rangs sont dans cette plage : "E1:E76, G1:G76, I1:I76, K1:K76, M1:M76" ; il y a 5 colonnes, et comme en ligne 1 c'est pour les en-têtes, les nombres sont sur 75 lignes (pas 76) ; il y a donc en tout 5 × 75 = 375 nombres.
* l'emplacement des résultats (sans les en-têtes de lignes et colonnes) est dans cette plage : Q2:X10 ; il y a donc en tout une place de 9 lignes × 8 colonnes = 72 nombres.
c'est donc évident qu'on ne peut pas afficher tous les rangs dans le tableau des résultats : même la 1ère colonne de rangs E n'y tient pas entièrement ! en effet, on ne peut pas afficher 73 à 75 de E74:E76 ; encore moins les rangs des colonnes G, I, K, M !
la solution serait donc d'agrandir le tableau des résultats !
soan
si possible d'ajouter comment obtenir les remplaçants ?
les remplaçants sont les profs qui ne surveille pas@Seddiki
* avec le même fichier "Classeur11122" de mon post #6 ou avec un autre fichier Excel ?
* quelle est la plage des rangs des remplaçants ?
* dans quelle plage mettre les résultats ? ce sera aussi en Q2:X10 ? ou ailleurs ?
ce sera peut-être mieux que tu fournisses un autre fichier exemple.
edit : comme tu as écrit : « je fais cet exemple pour préparer », je crois que tu vas bientôt fournir un autre fichier Excel. (où y'aura sûrement c'qu'il faut pour les remplaçants ! )
soan
Option Explicit
Private Sub Job(k As Byte)
Dim cl1 As Byte, lg1&, dlA&
Dim cl2 As Byte, lg2 As Byte, dlB As Byte
Dim dcB As Byte, lgA As Byte, lgB As Byte
If k = 1 Then 'pour les professeurs
cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 5: dlB = 13: dcB = 34
Else 'pour les remplaçants
cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 29: dlB = 37: dcB = 23
End If
lgA = lg1: lgB = lg2: dlA = dlA + 1: dlB = dlB + 1: dcB = dcB + 1
Do
With Cells(lg1, cl1)
Cells(lg2, cl2) = .Value: lg1 = lg1 + 1: lg2 = lg2 + 1
If lg1 = dlA Then lg1 = lgA: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub
If lg2 = dlB Then lg2 = lgB: cl2 = cl2 + 1: If cl2 = dcB Then Exit Sub
End With
Loop
End Sub
Sub Essai()
If ActiveSheet.Name <> "Feuil1" Then Exit Sub
Application.ScreenUpdating = 0
Job 1 'pour les professeurs
Job 2 'pour les remplaçants
End Sub
Merci@Seddiki
sur "Feuil1" :
* le tableau des profs est vide : aucune donnée en Q5:AH13
* le tableau des remplaçants est vide : aucune donnée en Q29:W37
* fais Ctrl e ➯ ça remplit entièrement les 2 tableaux
remarque : comme je n'ai pas vu de rangs pour les remplaçants, j'ai supposé que tu utilises les mêmes données que celles des rangs des profs : données en "E5:E79, G5:G79, I5:I79, K5:K79, M5:M79" ; si les rangs des remplaçants sont à un autre endroit, tu aurais dû l'indiquer !
(sauf erreur de ma part, j'ai rien vu à faire sur "Feuil2" !)
code VBA (28 lignes) :
VB:Option Explicit Private Sub Job(k As Byte) Dim cl1 As Byte, lg1&, dlA& Dim cl2 As Byte, lg2 As Byte, dlB As Byte Dim dcB As Byte, lgA As Byte, lgB As Byte If k = 1 Then 'pour les professeurs cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 5: dlB = 13: dcB = 34 Else 'pour les remplaçants cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 29: dlB = 37: dcB = 23 End If lgA = lg1: lgB = lg2: dlA = dlA + 1: dlB = dlB + 1: dcB = dcB + 1 Do With Cells(lg1, cl1) Cells(lg2, cl2) = .Value: lg1 = lg1 + 1: lg2 = lg2 + 1 If lg1 = dlA Then lg1 = lgA: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub If lg2 = dlB Then lg2 = lgB: cl2 = cl2 + 1: If cl2 = dcB Then Exit Sub End With Loop End Sub Sub Essai() If ActiveSheet.Name <> "Feuil1" Then Exit Sub Application.ScreenUpdating = 0 Job 1 'pour les professeurs Job 2 'pour les remplaçants End Sub
soan
With Cells(lg1, cl1)
et End With
étaient inutiles ; je les ai supprimés, puis à la place de Cells(lg2, cl2) = .Value
j'ai mis directement : Cells(lg2, cl2) = Cells(lg1, cl1)
; même utilisation qu'avant ; et mêmes résultats. Option Explicit
Private Sub Job(k As Byte)
Dim cl1 As Byte, lg1&, dlA&
Dim cl2 As Byte, lg2 As Byte, dlB As Byte
Dim dcB As Byte, lgA As Byte, lgB As Byte
If k = 1 Then 'pour les professeurs
cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 5: dlB = 13: dcB = 34
Else 'pour les remplaçants
cl1 = 5: lg1 = 5: dlA = 79: cl2 = 17: lg2 = 29: dlB = 37: dcB = 23
End If
lgA = lg1: lgB = lg2: dlA = dlA + 1: dlB = dlB + 1: dcB = dcB + 1
Do
Cells(lg2, cl2) = Cells(lg1, cl1): lg1 = lg1 + 1: lg2 = lg2 + 1
If lg1 = dlA Then lg1 = lgA: cl1 = cl1 + 2: If cl1 = 15 Then Exit Sub
If lg2 = dlB Then lg2 = lgB: cl2 = cl2 + 1: If cl2 = dcB Then Exit Sub
Loop
End Sub
Sub Essai()
If ActiveSheet.Name <> "Feuil1" Then Exit Sub
Application.ScreenUpdating = 0
Job 1 'pour les professeurs
Job 2 'pour les remplaçants
End Sub