XL 2016 [VBA] Rajout d'une condition sur deux macros excel

wishtolearn · 25 Février 2020

Bonjour à tous les experts Excel,

J'ai trouvé deux macros que je souhaite peaufiner et comme je n'y connais rien en VBA j'aurai donc besoin de vos lumières

1ère macro: j'aimerai que le cut de la macro se fasse uniquement en fonction de la colonne G ET de la colonne I (pour le moment il n'y a qu'une condition et je n'arrive pas à rajouter la seconde, la colonne I)

VB:

Sub Others()
    Dim i As Variant
    Dim endrow As Integer
    Dim DAV As Worksheet, OTH As Worksheet

    Set DAV = ActiveWorkbook.Sheets("Demandes à valider")
    Set OTH = ActiveWorkbook.Sheets("Other")

    endrow = DAV.Range("A" & DAV.Rows.Count).End(xlUp).Row

    For i = 2 To endrow
        If DAV.Cells(i, "G").Value = "Others" Then
           DAV.Cells(i, "G").EntireRow.Cut Destination:=OTH.Range("A" & OTH.Rows.Count).End(xlUp).Offset(1)
        End If
    Next
End Sub

2nde macro: j'aimerai exclure une feuille de cette macro de protection globale à savoir protège toutes les feuilles SAUF la feuille "Demandes à valider")

Code:

Sub UnProtectAll()
 
    On Error GoTo ErrorOccured
  
    Dim pwd1 As String
    pwd1 = InputBox("Please Enter the password")
    If pwd1 = "motdepasse" Then Exit Sub
    For Each ws In Worksheets
        ws.Unprotect Password:=pwd1
    Next
    MsgBox "All sheets UnProtected."

    Exit Sub
    
ErrorOccured:
    MsgBox "Sheets could not be UnProtected - Password Incorrect"
    Exit Sub
    
End Sub

Merci d'avance pour votre aide.

Staple1600 · 25 Février 2020

Bonsoir le fil

Une version tout en un (pour protection/déprotection)

VB:

Sub Protege()
Protection True
End Sub
Sub Deprotege()
Protection False
End Sub
Sub Protection(verrou As Boolean)
Dim pwd1$
pwd1 = InputBox("Please Enter the password")
For Each ws In Worksheets
If Not ws.Name = "Feuil1" Then '-< ici mettre le nom de la feuille à ne pas protéger
Select Case verrou
Case True
ws.Protect Password:=pwd1
Case False
ws.Unprotect Password:=pwd1
End Select
End If
Next
End Sub

GALOUGALOU · 25 Février 2020

bonjour le forum bonjour wishtolearn
commençons par la deuxième question
la macro proposé ne protège pas les feuilles mais au contraire enlève la protection
pour protéger et exclure une feuille voir le code

Enrichi (BBcode):

Sub ProtectAll()
  
    Dim pwd1 As String
    pwd1 = InputBox("Please Enter the password")
    If pwd1 = "motdepasse" Then Exit Sub
    For Each WS In Worksheets
        If WS.Name <> "Demandes à valider" Then
        WS.Protect Password:=pwd1
        End If
    Next
    MsgBox "All sheets Protected."

    Exit Sub
    
    
End Sub

pour la 1er question

if condition1 and condition2 then
cordialement
galougalou

wishtolearn · 25 Février 2020

Merci pour ton aide précieuse. Pour la 1ère question ça marche impec

Par contre pour la seconde j'ai un message d'erreur, quand je clique sur Débug ça m'affiche en jaune la ligne

VB:

If WS.Name <> "Demandes à valider" Then

Saurais-tu pourquoi?

GALOUGALOU · 25 Février 2020

Bonsoir le fil
Certainement un problème de nom avec la feuille
essaie de poster un classeur pour qu'on puisse juger sur pièce.
sur mon ordi la macro avait fonctionné sans problème
Cordialement
Galougalou

GALOUGALOU · 25 Février 2020

bonsoir le fil
en complément du post #4
un classeur avec le code du post #2
@+

wishtolearn · 25 Février 2020

Je vais tester à nouveau demain et je te tiens au courant.

Merci pour ta réponse.

Staple1600 · 25 Février 2020

Bonsoir le fil

Une version tout en un (pour protection/déprotection)

VB:

Sub Protege()
Protection True
End Sub
Sub Deprotege()
Protection False
End Sub
Sub Protection(verrou As Boolean)
Dim pwd1$
pwd1 = InputBox("Please Enter the password")
For Each ws In Worksheets
If Not ws.Name = "Feuil1" Then '-< ici mettre le nom de la feuille à ne pas protéger
Select Case verrou
Case True
ws.Protect Password:=pwd1
Case False
ws.Unprotect Password:=pwd1
End Select
End If
Next
End Sub

wishtolearn · 26 Février 2020

Ça fonctionne. J'ai pris le dernier code du coup qui est encore plus pratique. Merci à vous deux.

wishtolearn · 13 Mars 2020

Re,

Est-il possible de rajouter des feuille à cette macro? En fait j'ai cette même macro pour chaque feuille (1pour others, 1 pour demande facile, 1 pour demande difiiciles, etc..), le seul truc qui change c'est le titre de la feuille, puisque les conditions sont toujours les mêmes.

Ma question est donc: est-il possible d'avoir cette macro en global, plutôt que d'avoir à cliquer sur 10 boutons? Merci beaucoup par avance.

VB:

Sub Others()
    Dim i As Variant
    Dim endrow As Integer
    Dim DAV As Worksheet, OTH As Worksheet

    Set DAV = ActiveWorkbook.Sheets("Demandes à valider")
    Set OTH = ActiveWorkbook.Sheets("Other & Special Requests")

    endrow = DAV.Range("A" & DAV.Rows.Count).End(xlUp).Row

    For i = 2 To endrow
        If DAV.Cells(i, "G").Value = "Others" And DAV.Cells(i, "I").Value = "To be Done" Then
           DAV.Cells(i, "G").EntireRow.Cut Destination:=OTH.Range("A" & OTH.Rows.Count).End(xlUp).Offset(1)
        End If
    Next
End Sub

Staple1600 · 14 Mars 2020

Bonjour le fil, wishtolearn

Normalement nouvelle question=nouvelle discussion
(Cette dernière question n'ayant rien à voir avec celle posée dans le premier message de cette discussion)
Puisqu'elle est posée, je réponds néanmoins ici
(sous réserve d'avoir bien compris ce qu'il faut faire)

VB:

Sub Others_bis()
Dim i&, endrow&, ws As Worksheet, OTH As Worksheet
Set OTH = ActiveWorkbook.Sheets("Other & Special Requests")
For Each ws In Worksheets
If ws.Name <> "Other & Special Requests" Then
endrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    For i = 2 To endrow
        If ws.Cells(i, "G").Value = "Others" And ws.Cells(i, "I").Value = "To be Done" Then
           ws.Cells(i, "G").EntireRow.Cut Destination:=OTH.Range("A" & OTH.Rows.Count).End(xlUp).Offset(1)
        End If
    Next
End Sub

XL 2016 [VBA] Rajout d'une condition sur deux macros excel

wishtolearn

XLDnaute Nouveau

Staple1600

GALOUGALOU

XLDnaute Accro

wishtolearn

XLDnaute Nouveau

GALOUGALOU

XLDnaute Accro

GALOUGALOU

XLDnaute Accro

Pièces jointes

wishtolearn

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

wishtolearn

XLDnaute Nouveau

wishtolearn

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Discussions similaires