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

XL 2016 Copier cellule dans un autre onglets

H

hutch57

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Detection.xlsm
    22 KB · Affichages: 2
Trier par date Trier par votes
H

hutch57

XLDnaute Occasionnel
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
 

Pièces jointes

  • Detection.xlsm
    24 KB · Affichages: 3
Vote positif 0 Vote négatif
H

hutch57

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif

Jacky67

XLDnaute Barbatruc
hutch57 à dit:
Apres on peut faire mieux en macro je pense
Cliquez pour agrandir...
Bonjour,
Par exemple
VB: 
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
 

Pièces jointes

  • Detection.xlsm
    26.7 KB · Affichages: 2
Vote positif 0 Vote négatif
H

hutch57

XLDnaute Occasionnel
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.
 
Vote positif 0 Vote négatif

Jacky67

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

Pièces jointes

  • Detection V2.xlsm
    27.5 KB · Affichages: 4
Vote positif 0 Vote négatif

Phil69970

XLDnaute Barbatruc
@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
Cliquez pour agrandir...

Chaque fois que j'écris par exemple
Ws1.Range("D6:J6").Value = ""
Cliquez pour agrandir...
C'est comme si j'écris
Worksheets("DP").Range("D6:J6").Value = ""
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif

Phil69970

XLDnaute Barbatruc
@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é
 

Pièces jointes

  • Copie valeur sur feuille 2 V2.xlsm
    21.1 KB · Affichages: 1
Vote positif 0 Vote négatif
Solution
H

hutch57

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

C
  • Résolu(e)
XL 2021 Macro pour mise en page
Réponses
11
Affichages
441
candido57
C
M
  • Question
Microsoft 365 deux macros succesives et un bouton
2
Réponses
16
Affichages
626
Phil69970
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
568
dadu35
D
N
  • Résolu(e)
XL 2021 comment faire recherche dans une colonne et ligne
Réponses
5
Affichages
305
job75
  • Question
XL 2021 Problème ouverture fichier sur feuille protégée
Réponses
6
Affichages
535
treza88
  • Résolu(e)
Microsoft 365 Déplacement Shape
Réponses
2
Affichages
152
Cédric06400
T
  • Résolu(e)
XL 2019 Gestion "pseudo-évènements" sur un userform
2
Réponses
15
Affichages
447
ThierryP
T
N
  • Résolu(e)
Microsoft 365 Aide pour terminer un code Vba Excel
2
Réponses
23
Affichages
903
job75
A
  • Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
220
sylvanu
E
  • Résolu(e)
XL 2019 transfer listbox vers une colonne à partir de la 4 ligne
Réponses
2
Affichages
107
escudo
E
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…