Amelioration code macro

[eduraiss]

Bonjour le forum

Voila j'ai réussit à faire une macro pour lister les personnes qui sont de matin Aprés midi et Nuit


Mon problème est que j'ai trois boutons de transfert
Puis-je en avoir un?

Je joins le fichier

Merci de votre aide

 

[excalibur]

Re : Amelioration code macro

bonjour eduraiss le forum
a la fin de la macro transfert tu met ce code
call Transfert1
a la fin de la macro transfert1 tu met ce code
call Transfert2
tu gardes que le bouton lancer le transfert

 

[Compte Supprimé 979]

Re : Amelioration code macro

Salut Eduraiss, Excalibur

Ou alors tu en profites pour optimiser ton code 😉
Une seule SUB pour tout faire

Option Explicit
Sub Transfert()
Dim DerLigne As Integer, Lig
Dim Col As Byte, DerCol As Byte, ColCible As Byte
Dim VNom As String, DebNom As String, VHeure As Variant
'With Worksheets("Feuil1")
With ActiveSheet 'Worksheets("feuil1")
  .Range("AD3:AL62").ClearContents
  ' Trouver la dernière colonne du tableau
  DerCol = .Range("IV3").End(xlToLeft).Column
  ' Trouver la dernière ligne du tableau
  DerLigne = .Range("B" & Rows.Count).End(xlUp).Row
  ' Pour chaque ligne remplie du tableau
  For Lig = 3 To DerLigne
    ' Pour chaque colonne
    For Col = 3 To 8 Step 2
      VNom = .Cells(Lig, Col).Value
      DebNom = Left(VNom, 2)
      Select Case Col
        Case 3: ColCible = 30
        Case 5: ColCible = 32
        Case 7: ColCible = 34
        Case Else: ColCible = 0
      End Select
      If VNom <> "" And InStr(1, "R/A/M/", DebNom) > 0 Then
        DerLigne = .Cells(Rows.Count, ColCible).End(xlUp).Row + 1
        .Cells(DerLigne, ColCible) = VNom
        '.Cells(DerLigne, Colcible + 1) = Tabtemp(Ligne, 4) 'Heure
        .Cells(DerLigne, ColCible + 1) = .Cells(Lig, DerCol) 'Ligne
      End If
    Next
  Next
End With
End Sub

Voilà 😀

A+

 

[Bebere]

Re : Amelioration code macro

bonjour Eduraiss,Bruno,Escalibur
une autre solution,petit gâté va

Sub Transfert3()
Dim Cel As Range, L As Long, C As Byte, D As Byte, F As Byte, Nbre As Byte
Dim LetP As String

Application.ScreenUpdating = False

With Worksheets("Feuil1 (2)")
.Range("AD3:AL62").ClearContents
End With
'tu veux plus de cas tu augmentes nbre et tu ajoutes
'la "case" ou les "case" nécessaire
Nbre = 3
For C = 1 To Nbre

Select Case C

Case 1 'pétrissage
D = 4: F = 11: LetP = "PE"
Case 2 'l3
D = 14: F = 34: LetP = "L3"
Case 3 'l4
D = 37: F = 61: LetP = "L4"

End Select

With Worksheets("Feuil1 (2)")
'matin
For Each Cel In .Range("C" & D & ":C" & F)
If Cel <> "" Then
L = .Range("AD65536").End(xlUp).Row + 1
.Cells(L, "AD") = Cel
.Cells(L, "AE") = LetP
End If
Next Cel
'après midi
For Each Cel In .Range("E" & D & ":E" & F)
If Cel <> "" Then
L = .Range("AF65536").End(xlUp).Row + 1
.Cells(L, "AF") = Cel
.Cells(L, "AG") = LetP
End If
Next Cel
'nuit
For Each Cel In .Range("G" & D & ":G" & F)
If Cel <> "" Then
L = .Range("AH65536").End(xlUp).Row + 1
.Cells(L, "AH") = Cel
.Cells(L, "AI") = LetP
End If
Next Cel
End With

Next C

Application.ScreenUpdating = True

End Sub

à bientôt

 

[eduraiss]

Re : Amelioration code macro

Re

Merci a vous trois pour vos réponses je n'ai que l'embarra du choix

Deux précisions quant même
On sélection la colonne B en entier je voudrais la limiter a "B123" car les lignes au dessous comporte des valeurs qui me font remonter des chose que je n'ai pas besoin
Et les poste occupaient a mettre en colonne AE AG AI sont dans la colonne B

Merci a vous

 

[eduraiss]

Re : Amelioration code macro

re
j'ai trouver pour la limitede la colonne B par For Lig = 3 To 123

mais je n'arrive pas a trouver pour les postes je vais chercher les infos en colonne IP alors que je voudrais les info de la colonne B
Voici le code
Sub Transfert14()
Dim DerLigne As Integer, Lig
Dim Col As Byte, DerCol As Byte, ColCible As Byte
Dim VNom As String, DebNom As String, VHeure As Variant

With ActiveSheet 'Worksheets("feuil1")
.Range("CA4:CF62").ClearContents
' Trouver la dernière colonne du tableau
DerCol = .Range("IV3").End(xlToLeft).Column
' Trouver la dernière ligne du tableau
DerLigne = .Range("B" & Rows.Count).End(xlUp).Row
' Pour chaque ligne remplie du tableau
For Lig = 3 To 123
' Pour chaque colonne
For Col = 3 To 8 Step 2
VNom = .Cells(Lig, Col).Value
DebNom = Left(VNom, 2)
Select Case Col
Case 3: ColCible = 79
Case 5: ColCible = 81
Case 7: ColCible = 83
Case Else: ColCible = 0
End Select
If VNom <> "" And InStr(1, "R/A/M/", DebNom) > 0 Then
DerLigne = .Cells(Rows.Count, ColCible).End(xlUp).Row + 1
.Cells(DerLigne, ColCible) = VNom
'.Cells(DerLigne, Colcible + 1) = Tabtemp(Ligne, 4) 'Heure
.Cells(DerLigne, ColCible + 1) = .Cells(Lig, DerCol) 'Ligne
End If
Next
Next
End With
End Sub


merci de votre aide

 

[Bebere]

Re : Amelioration code macro

bonjour Eduraiss,Bruno,escalibur
changement effectué dans le code de Bruno et le mien
à bientôt

 

[eduraiss]

Re : Amelioration code macro

Bonjour le forum

C'est parfait bebere je n'avais pas trouvé, merci a excalibur et a bruno45 pour leurs participations

Cordialement