besoin d'aide

[fenec]

bonjour le forum
j'utilise actuellement une macro pour ma sauvegarde qui fonctionne tres bien mais mon souci est que la mise en page n'est pas respecter
j'entends par la que la largeur des colonnes et la hauteur des lignes ne sont pas mes memes
je ne sais d'ailleurs pas si cela est possible
voila la macro que j'utilise


Private Sub CommandButton1_Click()
'évite les basculements d'écrans
Application.ScreenUpdating = False
' bouton valider
nomfichier = ActiveWorkbook.Name
'ouverture nouveau classeur - 1 feuille - ne fonctionne pas sous XL97
défaut = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = défaut
nomfichier1 = ActiveWorkbook.Name
'copie la feuille
Windows(nomfichier).Activate
Range("Zone_d_impression").Copy
'colle dans nouveau fichier
Windows(nomfichier1).Activate
ActiveSheet.Range("B6").Select
ActiveSheet.Paste
'protège les cellules
ActiveSheet.Range(Selection.Address).Locked = True
ActiveSheet.Protect
ActiveSheet.Range("B6").Select
'enregistre sous le répertoire Factures, selon numéro de facture
ChDir (ThisWorkbook.Path & "\Users\Philippe\Documents\Sauvegardes Devis")
'choix avec nom par défaut, possibilité de changer le nom ou annuler
fermer = Application.GetSaveAsFilename(ActiveSheet.Range("E17").Value, "Fichiers Excel,*.xls")
'si annulation
If fermer = False Then
Windows(nomfichier1).Activate
ActiveWorkbook.Close Savechanges:=False
Exit Sub
End If
'sinon
ActiveWorkbook.SaveAs Filename:=fermer
ActiveWorkbook.Close
'retour sur modèle
'raz champ Aremplir

'incrément N° commande
num = Format(Val(Right(Range("R18"), 3)) + 1, "000")
ActiveSheet.Unprotect
Range("R18") = Left(Range("R18"), 8) & num
ActiveSheet.Protect
'sauve modèle avec numéro incrémenté
'ActiveWorkbook.Save
'réautorise les basculements d'écran
Application.ScreenUpdating = True

End Sub


merci d'avance

 

[blepy]

Re : besoin d'aide

Bonjour

Il faut rajouter derrière le : "ActiveSheet.Paste" qui lui colle les onnées
une instruction :
"ActiveSheet.PasteSpecial" avec comme argument
xlPasteColumnWidths pour coller la largeur originale des colonnes

 

[job75]

Re : besoin d'aide

Bonjour,

Pas top ces Activate et autres Select, ils sont inutiles ici (presque toujours le cas en VBA).

Donc remplacer le bloc :

'copie la feuille
Windows(nomfichier).Activate
Range("Zone_d_impression").Copy
'colle dans nouveau fichier
Windows(nomfichier1).Activate
ActiveSheet.Range("B6").Select
ActiveSheet.Paste
'protège les cellules
ActiveSheet.Range(Selection.Address).Locked = True

par :

'copie la feuille
Me.Cells.Copy ActiveSheet.[A1]
ActiveSheet.Cells.Clear
With Me.Range("Zone_d_impression")
  .Copy ActiveSheet.[B6]
  'verrouille les cellules
  ActiveSheet.[B6].Resize(.Rows.Count, .Columns.Count).Locked = True
End With

Ainsi les dimensions des lignes et colonnes seront copiées.

A+

 

[Robert]

Re : besoin d'aide

Bonjour le fil, bonjour le forum,

Comme je m'y suis penché dessus, je te propose cet autre solution en récupérant hauteurs de lignes et largeurs de colonnes dans deux tableaux dynamiques tbl et tbc :

Private Sub CommandButton1_Click()
 
'*************************
'déclaration des variables
Dim nomfichier As String
Dim nomfichier1 As String
Dim li As Range
Dim tbl() As Single
Dim x As Integer
Dim col As Range
Dim tbc() As Single
'*************************
 
'évite les basculements d'écrans
Application.ScreenUpdating = False
' bouton valider
nomfichier = ActiveWorkbook.Name
'ouverture nouveau classeur - 1 feuille - ne fonctionne pas sous XL97
défaut = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = défaut
nomfichier1 = ActiveWorkbook.Name
'copie la feuille
Windows(nomfichier).Activate
 
'***********************
'tableau des lignes tbl
x = 0
ReDim tbl(Range("Zone_d_impression").Rows.Count - 1)
For Each li In Range("Zone_d_impression").Rows
    tbl(x) = li.RowHeight
    x = x + 1
Next li
'***********************
 
'************************
'tableau des colonnes tbc
x = 0
ReDim tbc(Range("Zone_d_impression").Columns.Count - 1)
For Each col In Range("Zone_d_impression").Columns
    tbc(x) = col.ColumnWidth
    x = x + 1
Next col
'************************
 
Range("Zone_d_impression").Copy
'colle dans nouveau fichier
Windows(nomfichier1).Activate
ActiveSheet.Range("B6").Select
ActiveSheet.Paste
 
'*******************************
'récupère les hauteurs de lignes
x = 0
For Each li In Selection.Rows
    li.RowHeight = tbl(x)
    x = x + 1
Next li
'*******************************
 
'*********************************
'récupère les hauteurs de colonnes
x = 0
For Each col In Selection.Columns
   col.ColumnWidth = tbc(x)
   x = x + 1
Next col
'*********************************
 
'protège les cellules
ActiveSheet.Range(Selection.Address).Locked = True
ActiveSheet.Protect
ActiveSheet.Range("B6").Select
'enregistre sous le répertoire Factures, selon numéro de facture
ChDir (ThisWorkbook.Path & "\Users\Philippe\Documents\Sauvegardes Devis")
'choix avec nom par défaut, possibilité de changer le nom ou annuler
fermer = Application.GetSaveAsFilename(ActiveSheet.Range("E 17").Value, "Fichiers Excel,*.xls")
'si annulation
If fermer = False Then
    Windows(nomfichier1).Activate
    ActiveWorkbook.Close Savechanges:=False
    Exit Sub
End If
'sinon
ActiveWorkbook.SaveAs Filename:=fermer
ActiveWorkbook.Close
'retour sur modèle
'raz champ Aremplir
'incrément N° commande
num = Format(Val(Right(Range("R18"), 3)) + 1, "000")
ActiveSheet.Unprotect
Range("R18") = Left(Range("R18"), 8) & num
ActiveSheet.Protect
'sauve modèle avec numéro incrémenté
'ActiveWorkbook.Save
'réautorise les basculements d'écran
Application.ScreenUpdating = True
End Sub