Insertion user name dans une macro deja existante

[olivier972]

Bonjour à tous,

Je vous joint une macro que j'ai créé, dans cette macro juste avant l'impression j'aimerais inserer le nom d'utilisateur en case M65.
Sauriez vous m'aider ?

Grand merci par avance.

Cdlt

Sub IMPRESSIONDR2017()
'
' IMPRESSIONDR2017 Macro
'

'
ActiveSheet.Unprotect
Range("J4").Select
ActiveCell.FormulaR1C1 = "='HISTORIQUE DR'!R[-2]C[-4]+1"
Range("A4😀4").Select
Sheets("HISTORIQUE DR").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("OUVERTURE DR").Select
Rows("1:3").Select
Range("A3").Activate
Selection.EntireRow.Hidden = False
Rows("2:2").Select
Selection.Copy
Sheets("HISTORIQUE DR").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Rows("1:4").Select
Range("A4").Activate
Selection.EntireRow.Hidden = False
Range("A2:B2").Select
Sheets("OUVERTURE DR").Select
Rows("1:2").Select
Range("A2").Activate
Selection.EntireRow.Hidden = True
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1
ActiveWorkbook.Save
Range("A4😀4").Select
Selection.ClearContents
Range("E4").Select
Selection.ClearContents
Range("J4").Select
Selection.ClearContents
Range("A7:E7").Select
Selection.ClearContents
Range("F7:J7").Select
Selection.ClearContents
Range("K7:O7").Select
Selection.ClearContents
Range("C10😀10").Select
Selection.ClearContents
Range("A10:B10").Select
Selection.ClearContents
Range("E10:G10").Select
Selection.ClearContents
Range("H10:I10").Select
Selection.ClearContents
Range("J10").Select
Selection.ClearContents
Range("K10:M10").Select
Selection.ClearContents
Range("N10:O10").Select
Selection.ClearContents
Range("A14:B14").Select
Selection.ClearContents
Range("C14").Select
Selection.ClearContents
Range("D14").Select
Selection.ClearContents
Range("F14:H14").Select
Selection.ClearContents
Range("I14:O14").Select
Selection.ClearContents
Range("A19:G19").Select
Selection.ClearContents
Range("H19:O19").Select
Selection.ClearContents
Range("A23:C23").Select
Selection.ClearContents
Range("D23:E23").Select
Selection.ClearContents
Range("F23:J23").Select
Selection.ClearContents
Range("K23:O23").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=9
Range("F26:H26").Select
Selection.ClearContents
Range("D27:O30").Select
Selection.ClearContents
Range("D31:E32").Select
Selection.ClearContents
Range("F32:H32").Select
Selection.ClearContents
Range("I31:O32").Select
Selection.ClearContents
Range("F33:H33").Select
Selection.ClearContents
Range("I33:J34").Select
Selection.ClearContents
Range("K33:O34").Select
Selection.ClearContents
Range("F34:H34").Select
Selection.ClearContents
Range("D34:E34").Select
Selection.ClearContents
Range("D35:O36").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=12
Range("D37:E39").Select
Selection.ClearContents
Range("I37:J39").Select
Selection.ClearContents
Range("K37:O39").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=6
Range("D41:O44").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=12
Range("C48").Select
Selection.ClearContents
Range("E48:I48").Select
Selection.ClearContents
Range("C49").Select
Selection.ClearContents
Range("D49").Select
Selection.ClearContents
Range("E49").Select
Selection.ClearContents
Range("C50:E50").Select
Selection.ClearContents
Range("C51:E51").Select
Selection.ClearContents
Range("C52:E52").Select
Selection.ClearContents
Range("C53:H53").Select
Selection.ClearContents
Range("I53").Select
Selection.ClearContents
Range("J50").Select
Selection.ClearContents
Range("K50:M50").Select
Selection.ClearContents
Range("N50:O50").Select
Selection.ClearContents
Range("J51:O51").Select
Selection.ClearContents
Range("J52:M52").Select
Selection.ClearContents
Range("N52:O52").Select
Selection.ClearContents
Range("J53:O53").Select
Selection.ClearContents
Range("A57😀57").Select
Selection.ClearContents
Range("E57:I57").Select
Selection.ClearContents
Range("J57:O57").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-39
Range("M65:O65").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-78
Range("A4😀4").Select
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFormattingCells:=True
ActiveWorkbook.Save
End Sub

 

[Lone-wolf]

Bonjour olivier 🙂

Avant de créer une macro, demande aux Xldiens ce que tu veux faire, ça évite de faire le travail deux fois. Là maintenant, on est obligé de nettoyer tout le code. Et quelle est la première feuille activée???

EDIT: bonjour DoubleZero 🙂

 

[DoubleZero]

Bonjour, olivier972, le Forum,

Avant :

 ActiveSheet.Protect Objectivations:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True

Insérer :

Range("m65") = Environ("username")

Nota : éviter, autant que possible, l'emploi des "select". Pour cela, clic ici.

A bientôt 🙂

P. S. : Bonjour, Lone-wolf 🙂

 

[Lone-wolf]

Rebonjour à toutes et à tous

Option Explicit
Sub Impression()

With Sheets("BASE")
.Range("j4").FormulaR1C1 = "='HISTORIQUE DR'!R[-2]C[-4]+1"
End With

With Sheets("OUVERTURE DR").Select
.Rows("1:3").EntireRow.Hidden = False
.Rows("2:2").Copy
End With

With Sheets("HISTORIQUE DR")
.Range("m65") = Environ("username")
.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Rows("2:2").PasteSpecial Paste:=xlPasteValues
Sheets("OUVERTURE DR").Rows("1:2").EntireRow.Hidden = True
Application.CutCopyMode = False
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1

With Sheets("HISTORIQUE DR")
.Range("a4:e4", "j4", "a7:07", "a10:010", "a14:d14", "f14:o14", "a19:o19", _
"a23:o23", "f26:h26", "d27:o30", "d31:e32",  "f32:h32", "i31:032", "f33:h33",  _
"I33:J34", "k33:o34", "f34:h34", "d34:e34", "d35:o36", "d37:e39", "i37:j39",  _
"k37:o39", _"d41:o44", "c48", "e48:i48", "c49:e49", "c50:e52", "c53:i53",  _
"j50:o52", "a57:i57", "m65:o65").ClearContents
End With

ActiveSheet.Protect Objectivations:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True

ActiveWorkbook.Save

End Sub