XL 2013 Macro VBA copie valeur d'un classeur avec exceptions

  • Initiateur de la discussion Initiateur de la discussion Juan
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Juan

XLDnaute Junior
Bonjour à tous,

Je me permets de vous écrire car je bloque sur un code VBA (je suis une quiche et pas vraiment autodidacte dans ce domaine).

Voici mon objectif :
Faire une copie/valeur d'un classeur entier excepté certains onglets qui doivent garder leurs formules.

Voici le code sur lequel je travaille :

Code:
Sub testCopieValeursSeules()
Dim ws As Worksheet, wsArr(), NomFic$, nWBK As Workbook, i&
'création chaine pour nom du fichier
NomFic = ThisWorkbook.Path & "\" & Month(Date) - 1 & "-" & Year(Date) & " - Reporting Clients RGC"
ReDim wsArr(0)
'création d'un tableau avec le noms des feuilles choisies
For Each ws In ThisWorkbook.Worksheets
'on exclut une/plusieurs feuilles dans la liste selon leur nom
   If Not ws.Name = "YTD_TCD" Then
    wsArr(UBound(wsArr)) = ws.Name
    ReDim Preserve wsArr(UBound(wsArr) + 1)
    End If
    Next ws
ReDim Preserve wsArr(UBound(wsArr) - 1)
'on créee une copie du classeur ne contenant que les feuilles désirées
Sheets(wsArr).Copy
Set nWBK = ActiveWorkbook
'le contenu de toutes les feuilles passe en valeurs seules sauf quelques feuilles
For i = 1 To nWBK.Worksheets.Count
With nWBK.Worksheets(i)
    If ws.Name <> "TCD" Or ws.Name <> "TCD_POS" Then .UsedRange.Value = .UsedRange.Value
End If
End With
Next i
'ici ajouter ton code pour sauvegarder la copie
nWBK.SaveAs NomFic & ".xlsx", xlOpenXMLWorkbook
nWBK.Close
End Sub

Merci beaucoup pour votre aide!
Jean
 
Re : Macro VBA copie valeur d'un classeur avec exceptions

Bonjour Juan,

Code:
Sub CopierFichier()
Dim chemin$, nomfich$, exclu, w As Worksheet
With ThisWorkbook
  chemin = .Path & "\" 'chemin à adapter
  nomfich = "TOTO.xlsm" 'nom du fichier à adapter
  exclu = Array("xxx", "yyy", "zzz") 'noms des feuilles exclues, à adapter
  Application.DisplayAlerts = False
  On Error Resume Next
  Workbooks(nomfich).Close 'sil est ouvert on le ferme
  On Error GoTo 0
  .Save
  .SaveAs chemin & nomfich, .FileFormat
  For Each w In .Worksheets
    If IsError(Application.Match(w.Name, exclu, 0)) _
      Then w.UsedRange = w.UsedRange.Value
  Next
  .Save
End With
End Sub
A+
 
Re : Macro VBA copie valeur d'un classeur avec exceptions

Salut Job75, merci pr ton retour...

En revanche, tout ne marche pas comme prévu, notamment au niveau de l'enregistrement du nouveau fichier. Tu y trouveras en PJ un screenshot de l'erreur.

Voici le code utilisé:

Code:
Sub CopierFichier()
Dim chemin$, nomfich$, exclu, w As Worksheet
With ThisWorkbook
  chemin = .Path & "C:\Users\linierej\Desktop\ANGELIQUE\" 'chemin à adapter
  nomfich = "TOTO.xlsm" 'nom du fichier à adapter
  exclu = Array("xxx", "yyy", "zzz") 'noms des feuilles exclues, à adapter
  Application.DisplayAlerts = False
  On Error Resume Next
  Workbooks(nomfich).Close 'sil est ouvert on le ferme
  On Error GoTo 0
  .Save
  .SaveAs chemin & nomfich, .FileFormat
  For Each w In .Worksheets
    If IsError(Application.Match(w.Name, exclu, 0)) _
      Then w.UsedRange = w.UsedRange.Value
  Next
  .Save
End With
End Sub

Merci à toi,
Jean
 

Pièces jointes

  • Capture d'écran 2015-09-03 15.03.01.jpg
    Capture d'écran 2015-09-03 15.03.01.jpg
    52.2 KB · Affichages: 35
Re : Macro VBA copie valeur d'un classeur avec exceptions

Re,

Votre modif :

Code:
chemin = .Path & "C:\Users\linierej\Desktop\ANGELIQUE\" 'chemin à adapter
ne va pas du tout, je vous laisse chercher pourquoi.

Il faut travailler un peu soi-même si l'on veut progresser...

A+
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
7
Affichages
619
Réponses
8
Affichages
1 K
Réponses
3
Affichages
951
Réponses
7
Affichages
2 K
Réponses
1
Affichages
1 K
Retour