Sub Copie_Structure_Feuille_Valeur_Format_Commentaire()
'Dim t1 As Long, NomFAct As String, DerCelSel As Variant, DerCelAdr As Variant, NBcol As Long, NBLig As Long, cell As Range, i As Long
Dim LargCol(1048576), HautLig(1048576) ', DercelLig As Long, DerCelCol As Long, Ilig As Long, ICOl As Long
If [A1].SpecialCells(xlLastCell).Address = "$A$1" And [A1] = "" Then Exit Sub
t1 = Timer
Application.ScreenUpdating = False
NomFAct = ActiveSheet.Name
'DerCelSel = ActiveCell.SpecialCells(xlLastCell).Select
'DerCelAdr = ActiveCell.Address
'DercelCol = ActiveCell.Column
'DercelLig = ActiveCell.Row
'Attenton si bug avec des feuille vide mais à la fin à 1 milllions de ligne.Voir avec les paramètres suivant:
'If DercelLig > 1000 Then DercelLig = 65000
'If DercelCol > 1000 Then DercelCol = 65000
'MsgBox Cells.Find("*", [A1], , , 1, 2).Row
DercelLig = Cells.Find("*", [A1], , , 1, 2).Row
DercelCol = Cells.Find("*", [A1], , , 1, 2).Column
NBcol = 0
For ICOl = 1 To DercelCol
If Cells(1, ICOl).ColumnWidth <> 0 Then NBcol = NBcol + 1: LargCol(NBcol) = Cells(1, ICOl).ColumnWidth
Next
NBLig = 0
For Ilig = 1 To DercelLig
If Rows(Ilig & ":" & Ilig).RowHeight <> 0 Then NBLig = NBLig + 1: HautLig(NBLig) = ActiveSheet.Rows(Ilig & ":" & Ilig).RowHeight
Next
'Stop
' A voir pour traitement de type Tableau
'For Each cell In ActiveSheet.Range(Cells(1, 1), Cells(DercelLig, DerCelCol))
'Traitement tableau
'Next
Sheets.Add
For i = 1 To NBcol
Cells(1, i).ColumnWidth = LargCol(i)
Next
For i = 1 To NBLig
Rows(i & ":" & i).RowHeight = HautLig(i)
Next
ActiveSheet.Next.Select
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
ActiveSheet.Previous.Select
Range("A1").Select
'Mettre pour chaque cellule la valeur et le format et le commentaire
'Posibilité de mettre la formule avec xlPasteFormulas mais commenter xlPasteValues
'Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Copie la valeur
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Copie le Format
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Copie les Commentaires
Selection.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
On Error Resume Next 'au cas ou le nom de l'onglet existe
If Len(NomFAct) < 27 Then ActiveSheet.Name = "CV " & Replace(NomFAct, " ", "") Else ActiveSheet.Name = "CV " & Replace(Mid(NomFAct, 1, 14), " ", "") & Replace(Right(NomFAct, 14), " ", "")
Application.CutCopyMode = False
Application.ScreenUpdating = True
'MsgBox Timer - t1
Application.StatusBar = Format(Timer - t1, "0.0") & " secondes"
End Sub