XL 2016 Copier cellule dans un autre onglets

[hutch57]

Bonsoir le forum,
J'ai un petit souci de macro, je voudrais sauvegarder les cellules D a J dans un autre onglet sachant que dans la feuille les 2 onglets sont protégé par un mot de passe, c'est la que ca coince j'ai essayé de combiner les 2 modules en 1 seul mais ca ne fonctionne pas.
Module1
Sub SaveM2()

Sheets("DP").Select

Range("C6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("D6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If


Range("E6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("F6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("G6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("H6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Module2
Sub test()

ActiveSheet.Unprotect "1234"
Sheets("Datas").Select
ActiveSheet.Unprotect "1234"
Sheets("DP").Select
Range("B6:J6").Select
Selection.Copy
Sheets("Datas").Select
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A8").Select
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False
Sheets("DP").Select
Range("D6:I6").Select
Selection.ClearContents
Range("D6").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Un avis! en attendant j'essaye de faire mieux.

 

[hutch57]

Rebonsoir,
C'est bon ca fonctionne j'ai trouver comment faire, par contre les feuille sont déprotégé puis reprotégé mais sans le mot de passe, bizarre.
Voici la macro modifier
Sub SaveM2()

Sheets("DP").Select


Range("C6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("D6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If


Range("E6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("F6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("G6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If

Range("H6").Select
If ActiveCell = "" Then
MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE"
End
End If


ActiveSheet.Unprotect "1234"
Sheets("Datas").Select
ActiveSheet.Unprotect "1234"
Sheets("DP").Select
Range("B6:J6").Select
Selection.Copy
Sheets("Datas").Select
Range("a65536").End(xlUp).Select

ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("A8").Select
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False
Sheets("DP").Select
Range("D6:I6").Select
Selection.ClearContents
Range("D6").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

 

[hutch57]

Apres on peut faire mieux en macro je pense

 

[hutch57]

J'ai trouvé comment remettre sur la feuille principale mais pas sur celle des datas

Selection.ClearContents
ActiveSheet.Protect "1234"

a la place de
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

 

[Jacky67]

Apres on peut faire mieux en macro je pense

Bonjour,
Par exemple

Sub SaveM2()
    Dim C As Range
    Application.ScreenUpdating = False
    With Feuil1
        For Each C In .[c6:i6]
            If C = "" Then
                MsgBox "UNE VALEUR EST OBLIGATOIRE POUR CETTE CELLULE (" & C.Offset(-1) & ")"
                C.Select: Exit Sub
            End If
        Next
        Feuil2.Unprotect "1234"
        .[b6:j6].Copy Feuil2.Range("a" & Feuil2.Cells(Rows.Count, "a").End(xlUp).Row + 1)
        Feuil2.Protect "1234"
    End With
End Sub

 

[hutch57]

Bonsoir Jacky67,
C'est mieux mais l'heure ne change plus, j'avais mis cette formule dans la feuil1pour ca/
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Sheets("DP").Select
ActiveSheet.Unprotect "1234"
Target.Offset(0, -2) = Date
End If

If Not Application.Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Sheets("DP").Select
Target.Offset(0, -1) = Time
ActiveSheet.Protect "1234"
End If
End Sub

et il n'efface pas les cellules de D a J sur le feuille DP.

 

[Phil69970]

Bonjour à tous

@hutch57

Je te propose ce fichier
J'ai tout revu

Merci de ton retour

 

[Jacky67]

Bonsoir Jacky67,
C'est mieux mais l'heure ne change plus, j'avais mis cette formule dans la feuil1pour ca/
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Sheets("DP").Select
ActiveSheet.Unprotect "1234"
Target.Offset(0, -2) = Date
End If

If Not Application.Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Sheets("DP").Select
Target.Offset(0, -1) = Time
ActiveSheet.Protect "1234"
End If
End Sub

et il n'efface pas les cellules de D a J sur le feuille DP.

Ok
La date et l'heure se mettent à jour avec la validation.
La saisie s'efface après validation

 

[hutch57]

Bonsoir Jacky, Phil,
Merci a vous deux ca fonctionne a merveille, Phil maintenant je vais essayer de comprendre ton code il ma l'air bien mais je dois comprendre son fonctionnement.
Encore merci

 

[hutch57]

C'est surtout les WS que j'essaye de comprendre
Ws1 As Worksheet, Ws2 As Worksheet

 

[Phil69970]

@hutch57

Le code est assez facile à comprendre.

En gros c'est le nom des 2 feuilles que j'ai mise en variable cela évite de les répéter

Set Ws1 = Worksheets("DP") '<== c'est la feuille DP
Set Ws2 = Worksheets("Datas") '<== c'est la feuille Datas

Chaque fois que j'écris par exemple

Ws1.Range("D6:J6").Value = ""

C'est comme si j'écris

Worksheets("DP").Range("D6:J6").Value = ""

 

[hutch57]

OK Phil c'est plus clair, je m'améliore de jour en jour grâce a vous, vous êtes top.

 

[Phil69970]

@hutch57

Le même fichier avec le code commenté

Par contre la validation est erroné c'est soit le post de Jacky soit le mien mais cela ne peut pas être le tien car tu n'as rien trouvé

 

[hutch57]

Bonsoir Phil
C'est ton code que j'ai retenu il est top, une merveille merci

 

[hutch57]

Phil,
par contre dans ma feuil1 j'avais ca en code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Sheets("DP").Select
ActiveSheet.Unprotect "*1234*"
Target.Offset(0, -2) = Date
End If

If Not Application.Intersect(Target, Range("D6")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Sheets("DP").Select
Target.Offset(0, -1) = Time
ActiveSheet.Protect "*1234*"
End If
End Sub
Comment tu as intégrer ca dans le code
merci de ton retour