Format des cellules après fusion de fichiers ouverts
Bonjour à tous,
Je me permets de vous solliciter car novice en matière de VBA et je ne trouve pas la solution sur les forums.
Je rencontre un souci avec une macro qui fonctionne très bien sur Excel 2010 mais ne fonctionne plus sur un poste ayant Excel 365 2021.
Le but étant de copier/coller automatiquement des classeurs ouverts (qui ne comportent qu'un seul onglet chacun) dans des onglets d'un autre classeur (FICHIER PRINCIPAL)
Voici la macro en question :
Sub MacroCEP8()
'
' MacroCEP8 Macro
'
'
Range("A1").Select
Windows("1ER FICHIER A COPIER.xls").Activate
Cells.Select
Selection.Copy
Windows("FICHIER PRINCIPAL.xlsm").Activate
Range("A1").Select
ActiveSheet.Paste
Range("B8").Select
Sheets("1").Select
Range("A1").Select
Windows("2EME FICHIER A COPIER.xls").Activate
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows("FICHIER PRINCIPAL.xlsm").Activate
ActiveSheet.Paste
Range("D7").Select
Sheets("2").Select
Range("A1").Select
End Sub
J'ai essayé avec Workbooks().activate mais cela ne change rien. D'après ce que je trouve cela pourrait venir venir de windows qui n'activerait pas les classeurs.
J'ai trouvé d'autres personnes ayant le même problème sur les forums mais je n'ai pas trouvé de réponse.
En cherchant j'ai trouvé la macro suivante qui serait une meilleure solution et répondrait mieux à mon besoin (les classeurs une fois copiés sont fermés) mais quand les données sont collées cela ajoute des guillemets sur les chiffres, au lieu de faire un copier/coller. Le seul inconvénient de cette macro est de copier tous les classeurs sur une même feuille.
Sub CombinerPlusieursFeuilleDansClasseurExistant()
On Error GoTo eh
'Déclaration des variables pour contenir les objets requis
Dim wbDestination As Workbook
Dim wbSource As Workbook
Dim wsDestination As Worksheet
Dim wb As Workbook
Dim sh As Worksheet
Dim strSheetName As String
Dim strDestName As String
Dim iRws As Integer
Dim iCols As Integer
Dim totRws As Integer
Dim rngEnd As String
Dim rngSource As Range
'Défini le classeur actif en tant que classeur de destination
Set wbDestination = ActiveWorkbook
'Récupère le nom du classeur actif
strDestName = wbDestination.Name
'Désactive la mise à jour de l'écran pour accélérer l'exécution
Application.ScreenUpdating = False
'Création d'une nouvelle feuille de destination dans le classeur actif
Application.DisplayAlerts = False
'Ignore les erreurs dans le cas où la feuille n'existerait pas
On Error Resume Next
ActiveWorkbook.Sheets("Consolidation").Delete
'Réinitialise la gestion des erreurs initiale
On Error GoTo eh
Application.DisplayAlerts = True
'Ajoutes une nouvelle feuille au classeur
With ActiveWorkbook
Set wsDestination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
wsDestination.Name = "Consolidation"
End With
'Boucle sur chaque fichier ouvert pour récupérer les données
For Each wb In Application.Workbooks
If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
Set wbSource = wb
For Each sh In wbSource.Worksheets
'Récupère le nombre de rangée dans le feuille
sh.Activate
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
iRws = ActiveCell.Row
iCols = ActiveCell.Column
rngEnd = sh.Cells(iRws, iCols).Address
Set rngSource = sh.Range("A1:" & rngEnd)
'Trouves la dernière rangée dans la feuille de destination
wbDestination.Activate
Set wsDestination = ActiveSheet
wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
totRws = ActiveCell.Row
'Vérifie qu'il y a assez de rangée libre dans la feuille de destination pour coller les données
If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
MsgBox "There are not enough rows to place the data in the Consolidation worksheet."
GoTo eh
End If
'Ajoute une rangée pour coller les données dans la prochaine rangée vide
If totRws <> 1 Then totRws = totRws + 1
rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
Next sh
End If
Next wb
'Fermeture des classeurs ouverts à l'exception du classeur actif et du classeur personnel
For Each wb In Application.Workbooks
If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
wb.Close False
End If
Next wb
'Nettoyage des objets pour libérer la mémoire
Set wbDestination = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
Set rngSource = Nothing
Set wb = Nothing
'Active la mise à jour de l'écran
Application.ScreenUpdating = True
Exit Sub
eh:
MsgBox Err.Description
End SubUne aide ou un conseil serait bienvenus :o)
Merci par avance !
Laurent
Bonjour,
Il faudrait expliquer la façon et sur quoi vous collez vos données dans le fichier principal :
- Sur le même onglet ? Si oui lequel, sinon lesquels.
- Les données sont elles collées les unes en dessous des autres ? Sinon comment ?
Bonjour Éric,
Pour essayer de faire simple, j'ai un classeur principal comportant des onglets ("F", "ET" et "PR") dans lesquels je colle les données des classeurs ouverts (qui ne comportent qu'une feuille chacun) qui se nomment "TB", "ETTB" et "PR".
Les classeurs TB, ETTB et PR sont créés par un progiciel et non pas pour vocation a être sauvegardés, leurs données sont juste intégrées dans le fichier principal.
Seul le fichier principal est sauvegardé par la suite.
Classeur TB -> Onglet F du classeur principal
Classeur ETTB -> Onglet ET du classeur principal
Classeur PR -> Onglet PR du classeur principal
J'espère que ces infos seront utiles et surtout claires.
Merci !
A tester :
Option Explicit
Sub MacroCEP8()
Dim I As Integer, J As Integer
Dim DlShF As Long, DlShET As Long, DlShPR As Long
Dim WbPrincipal As Workbook
Dim ShF As Worksheet, ShET As Worksheet, ShPR As Worksheet
Set WbPrincipal = ActiveWorkbook
With WbPrincipal
Set ShF = .Sheets("F")
Set ShET = .Sheets("ET")
Set ShPR = .Sheets("PR")
End With
DlShF = ShF.Cells(ShF.Rows.Count, 1).End(xlUp).Row + 1
DlShET = ShET.Cells(ShET.Rows.Count, 1).End(xlUp).Row + 1
DlShPR = ShPR.Cells(ShPR.Rows.Count, 1).End(xlUp).Row + 1
For I = 1 To Workbooks.Count
With Workbooks(I)
Select Case .Name
Case WbPrincipal.Name
Case Else
For J = 1 To .Sheets.Count
With .Sheets(J)
Select Case .Name
Case "TB"
.UsedRange.Copy Destination:=ShF.Cells(DlShF, 1)
Case "ETTB"
.UsedRange.Copy Destination:=ShET.Cells(DlShET, 1)
Case "PR"
.UsedRange.Copy Destination:=ShPR.Cells(DlShPR, 1)
End Select
End With
Next J
End Select
End With
Next I
Set WbPrincipal = Nothing
Set ShF = Nothing: Set ShET = Nothing: Set ShPR = Nothing
End SubBonjour Éric,
Malheureusement rien ne se passe quand je lance la macro :o(
Mettez en ligne vos fichiers sans données confidentielles.
Bonjour,
Voici les fichiers, les fichiers ETTB, TB et PR sont ouverts depuis le progiciel et sont enregistrés dans un dossier dans C:\NOM_DOSSIER\DOC\ETTB.xls (ces enregistrements ne sont pas utilisés car normalement je lance la macro quand ces fichiers sont générés puis je les ferme), puis écrasés lors des générations suivantes de ces fichiers.
Pour rappel la macro de mon premier post marche parfaitement sur Excel 2010, c'est sur Excel 365 2021 que je rencontre le problème.
Bonne journée !
Essayez :
Nb : Les 3 fichiers sources sont ouverts.
Option Explicit
Sub MacroCEP8()
Dim I As Integer, J As Integer
Dim DlShF As Long, DlShET As Long, DlShPR As Long
Dim WbPrincipal As Workbook
Dim ShF As Worksheet, ShET As Worksheet, ShPR As Worksheet
Set WbPrincipal = ActiveWorkbook
With WbPrincipal
Set ShF = .Sheets("F")
Set ShET = .Sheets("ET")
Set ShPR = .Sheets("PR")
End With
DlShF = ShF.Cells(ShF.Rows.Count, 1).End(xlUp).Row + 1
DlShET = ShET.Cells(ShET.Rows.Count, 1).End(xlUp).Row + 1
DlShPR = ShPR.Cells(ShPR.Rows.Count, 1).End(xlUp).Row + 1
For I = 1 To Workbooks.Count
With Workbooks(I)
Select Case LCase(.Name)
Case LCase(WbPrincipal.Name)
Case "tb.xls"
.Sheets(1).UsedRange.Copy Destination:=ShF.Cells(DlShF, 1)
Case "ettb.xls"
.Sheets(1).UsedRange.Copy Destination:=ShET.Cells(DlShET, 1)
Case "pr.xls"
.Sheets(1).UsedRange.Copy Destination:=ShPR.Cells(DlShPR, 1)
End Select
End With
Next I
Set WbPrincipal = Nothing
Set ShF = Nothing: Set ShET = Nothing: Set ShPR = Nothing
End SubMerci Éric pour votre aide, cela fonctionne parfaitement sous Excel 2010 mais pas sur Excel 365 2021, seul le fichier PR s'intègre dans l'onglet PR.
J'ai essayé en renommant les feuilles du même nom que les fichiers (TB et ETTB) mais cela ne change rien. Je ne trouve pas d'explication logique :o(
Je ne vois pas pourquoi cela marche avec Excel 2021 et pas Excel 365 2021, surtout pourquoi sur un classeur et pas sur les 2 autres.
J'ai interrogé la maintenance du progiciel mais vu qu'il s'agit aussi de fichiers *.xls je ne vois pas.
Merci encore pour votre aide !
Je suis sur 365.
Vous avez essayé sur les 4 fichiers que vous m'avez envoyés ?
Que donnent les MsgBox dans ce code ?
Récupérez-vous les noms des fichiers et les adresses des aires à copier ?
Sub MacroCEP8()
Dim I As Integer, J As Integer
Dim DlShF As Long, DlShET As Long, DlShPR As Long
Dim WbPrincipal As Workbook
Dim ShF As Worksheet, ShET As Worksheet, ShPR As Worksheet
Set WbPrincipal = ActiveWorkbook
With WbPrincipal
Set ShF = .Sheets("F")
Set ShET = .Sheets("ET")
Set ShPR = .Sheets("PR")
End With
DlShF = ShF.Cells(ShF.Rows.Count, 1).End(xlUp).Row + 1
DlShET = ShET.Cells(ShET.Rows.Count, 1).End(xlUp).Row + 1
DlShPR = ShPR.Cells(ShPR.Rows.Count, 1).End(xlUp).Row + 1
For I = 1 To Workbooks.Count
With Workbooks(I)
Select Case LCase(.Name)
Case LCase(WbPrincipal.Name)
Case "tb.xls"
MsgBox Workbooks(I).Name & " " & .Sheets(1).UsedRange.Address
.Sheets(1).UsedRange.Copy Destination:=ShF.Cells(DlShF, 1)
Case "ettb.xls"
MsgBox Workbooks(I).Name & " " & .Sheets(1).UsedRange.Address
.Sheets(1).UsedRange.Copy Destination:=ShET.Cells(DlShET, 1)
Case "pr.xls"
MsgBox Workbooks(I).Name & " " & .Sheets(1).UsedRange.Address
.Sheets(1).UsedRange.Copy Destination:=ShPR.Cells(DlShPR, 1)
End Select
End With
Next I
Set WbPrincipal = Nothing
Set ShF = Nothing: Set ShET = Nothing: Set ShPR = Nothing
End SubLe code envoyé ce matin fonctionne bien sur excel 365 mais uniquement lorsque j'ouvre les classeurs depuis un dossier (après les avoir sauvegardés), pas lorsque je le lance après que les fichiers aient été générés depuis le progiciel, il semble que ce ne soit pas le code le problème mais son fonctionnement sur le poste en question. Sur le mien (Excel 2010) tout va bien, quelle raison pourrait expliquer ce problème sur Excel 365 ? C'est comme si le code ne trouvait pas les classeurs sous Excel 365.
Je vous remercie grandement pour votre aide et votre code !
Quel est le chemin de ces fichiers ?
Bonjour,
Les fichiers sont dans le dossier C:\Sielwin\DOC et sont remplacés à chaque génération depuis le progiciel.
Dans ce code, les fichiers sont ouverts au fur et à mesure. Il faut vérifier la syntaxe des noms des fichiers (minuscules, majuscules).
Sub MacroCEP8_V2()
Dim I As Integer
Dim DlShF As Long, DlShET As Long, DlShPR As Long
Dim Repertoire As String, Chemin As String
Dim ListeFichiers As Variant
Dim WbPrincipal As Workbook, WbSource As Workbook
Dim ShF As Worksheet, ShET As Worksheet, ShPR As Worksheet
Repertoire = "C:\Sielwin\DOC\"
' Repertoire = ActiveWorkbook.Path & "\" ' A adapter
ListeFichiers = Array("tb.xls", "ettb.xls", "pr.xls") ' Mettre la syntaxe exacte
Set WbPrincipal = ActiveWorkbook
With WbPrincipal
Set ShF = .Sheets("F")
Set ShET = .Sheets("ET")
Set ShPR = .Sheets("PR")
End With
DlShF = ShF.Cells(ShF.Rows.Count, 1).End(xlUp).Row + 1
DlShET = ShET.Cells(ShET.Rows.Count, 1).End(xlUp).Row + 1
DlShPR = ShPR.Cells(ShPR.Rows.Count, 1).End(xlUp).Row + 1
For I = LBound(ListeFichiers) To UBound(ListeFichiers)
Chemin = Repertoire & ListeFichiers(I)
Set WbSource = Workbooks.Open(Chemin)
With WbSource
Select Case LCase(.Name)
Case LCase(WbPrincipal.Name)
Case "tb.xls"
.Sheets(1).UsedRange.Copy Destination:=ShF.Cells(DlShF, 1)
Case "ettb.xls"
.Sheets(1).UsedRange.Copy Destination:=ShET.Cells(DlShET, 1)
Case "pr.xls"
.Sheets(1).UsedRange.Copy Destination:=ShPR.Cells(DlShPR, 1)
End Select
End With
WbSource.Close savechanges:=False
Set WbSource = Nothing
Next I
Set WbPrincipal = Nothing: Set WbSource = Nothing
Set ShF = Nothing: Set ShET = Nothing: Set ShPR = Nothing
End SubUn grand Merci Éric pour votre aide et efficacité, cela fonctionne à présent correctement sur Excel 365 !
Je vous souhaite une bonne journée.
Laurent