Corr°code VB [RESOLU] : copie [VALEURSdirects] xSheets"1" (wbk (.XLS) / répertoire) vers 1wbk

[zebanx]

Bonsoir,

Ce code fonctionne très bien et copie chaque feuille 1 du répertoire vers le fichier qui contient la macro.
Cette feuille 1 étant -pour chacun des fichiers de départ -"chargée", je recherche uniquement une copie valeur DIRECTE dans ce répertoire-tampon (ie : la solution copie totale et copie valeur après ne me permet pas de dégager trop d'octets lors de l'enregistrement).
Mais je n'arrive pas à le faire après plusieurs tentatives.

Pourriez-vous s'il vous plait corriger ce code ?

Vous en remerciant
cordialement
thierry

-----
Sub XLS_recap()
Dim k As Integer
ChDir ActiveWorkbook.Path
Set classeurMaitre = ActiveWorkbook
compteur = 1
nf = Dir("*.xl*")
Do While nf <> ""
If nf <> classeurMaitre.Name Then
Workbooks.Open Filename:=nf
k = 1
On Error Resume Next
Sheets(k).Copy After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count)
' Recherche uniquement d'une copie valeur
On Error GoTo 0
Workbooks(nf).Close False
End If
nf = Dir
Loop
End Sub

 

[Patrice33740]

Bonjour,

Essaies :

Option Explicit
Sub XLS_recap()
Dim classeurMaitre As Workbook, wbk As Workbook
Dim wsh As Worksheet, rng As Range
  ChDir ThisWorkbook.Path
  Set classeurMaitre = ThisWorkbook
  nf = Dir("*.xl*")
  Application.ScreenUpdating = False
  Do While nf <> ""
  If nf <> classeurMaitre.Name Then
  With classeurMaitre.Worksheets
  Set wsh = .Add(after:=.Item(.Count))
  End With
  Set wbk = Workbooks.Open(Filename:=nf)
  Set rng = wbk.Worksheets(1).UsedRange
  wsh.Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
  wbk.Close False
  End If
  nf = Dir
  Loop
  Application.ScreenUpdating = True
End Sub

 

[Robert]

Bonjour Zebanx, bonjour le forum,

Essaie comme ça :

Sub XLS_recap()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)

Set CD = ThisWorkbook 'définit le classeur destination CD
CA = ActiveWorkbook.Path & "\" 'définit le chemin d'accès CA
CD.Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position dans la classeur destination
Set OD = ActiveSheet 'définit l'onglet destination OD
F = Dir(CA & "*.xl*") 'définit le premier fichier excel F du dossier ayant CA conne chemin d'accès
Do While F <> "" 'exécute tant qu'il existe des fichier F
  If F <> CD.Name Then 'condition si le fichier F n'est pas le classeur destination
  Workbooks.Open CA & F 'ouvre le fichier F
  Set CS = ActiveWorkbook 'définit le classeur source
  Set OS = CS.Sheets(1) 'définit l'onglet source
  'copie toutes les cellules de l'onglet source et colle les valeurs dans A1 de l'onglet destination
  OS.Cells.Copy OD.Range("A1").PasteSpecial(xlPasteValues)
  CS.Close False 'ferme le classeur source sans enregistrer
  End If 'fin de la condition
  F = Dir 'définit le prochain fichier excel F du dossier ayant CA comme chemin d'accès
Loop 'boucle
End Sub

[Édition]
Bonjour Patrice nos posts se sont croisés...

 

[zebanx]

Bonjour Patrice, Bonjour Robert.

Merci pour ces codes très intéressants par leurs différenciations et le temps que vous y avez consacré.
Il y a plus de modifications qu'anticipées pour une instruction de copie valeur et ça c'est utile aussi, j'aurais perdu beaucoup de temps à chercher une formule idoine qui n'existe pas.

A l'utilisation :

- code Patrice :
fonctionne parfaitement.
Petite question : Est-ce à cause des used.range (pas l'habitude de les utiliser) que le code serait un peu long svp (ie : si chaque feuille 1 (par WBK rappatrié) fait plus de 25000 lignes par exemple et qu'il y a 12/15 WBK à intégrer) ?
On n'a pas le cas dans le zip joint mais c'est le cas avec mes gros fichiers à rappatrier (environ 40 secondes ce qui n'est pas long non plus -).

- code Robert :
il y a une erreur de #1004 sur la ligne
OS.Cells.Copy OD.Range("A1").PasteSpecial(xlPasteValues)

N'est-ce pas lié (peut-être) à la ligne de code suivante aussi ?
CD.Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position dans la classeur destination
--> cette ligne de code ne devrait-elle pas SVP figurer dans la boucle pour créer un sheets.add à chaque ouverture d'un workbook du répertoire (j'ai essayé quelque chose mais ça bug aussi) ?

Je vous remercie par avance pour les compléments d'informations et me permets de mettre un répertoire avec des fichiers allégés pour voir l'exécution de vos codes.

Cdlt et encore merci !
thierry

 

[Robert]

Erreur de manip !...

 

[Robert]

Re,

J'avoue que je n'avais pas testé le code proposé. Tu as tout à fait raison la ligne de création d'un nouvel onglet est mal placée. Le problème venait du copier/coller les valeurs sur une seule ligne. Quand on le fait sur deux ça passe. J'ai aussi rajouté deux lignes qui permettent d'empêcher les messages Excel car pour chaque copier/coller j'avais un message indiquant que le presse-papier contenait beaucoup de données (j'avais pourtant remplacé Cells par UsedRange mais ça ne résolvait pas le problème)...
Le nouveau code (testé cette fois) :

Option Explicit

Sub XLS_recap_ROBERT()
' code de robert
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)

Application.ScreenUpdating = False 'empêche les rafraîchissements d'écran
Application.DisplayAlerts = False 'désactive les messages d'Excel
Set CD = ThisWorkbook 'définit le classeur destination CD
CA = ActiveWorkbook.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xl*") 'définit le premier fichier excel F du dossier ayant CA conne chemin d'accès
Do While F <> "" 'exécute tant qu'il existe des fichier F
  If F <> CD.Name Then 'condition si le fichier F n'est pas le classeur destination
  CD.Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position dans la classeur destination
  Set OD = ActiveSheet 'définit l'onglet destination OD
  Workbooks.Open CA & F 'ouvre le fichier F
  Set CS = ActiveWorkbook 'définit le classeur source
  Set OS = CS.Sheets(1) 'définit l'onglet source
  OS.UsedRange.Copy 'copie la plage éditée de l'onglet source
  OD.Range("A1").PasteSpecial (xlPasteValues) 'colle les valeurs dans A1 de l'onglet source
  CS.Close False 'ferme le classeur source sans enregistrer
  End If 'fin de la condition
F = Dir 'définit le prochain fichier excel F du dossier ayant CA comme chemin d'accès
Loop 'boucle
Application.DisplayAlerts = True 'active les messages d'Excel
MsgBox "Traitement des données terminé !"
End Sub

 

[zebanx]

Traitement magique et merci pour tout le temps consacré au retour de mail et aux explications dans le code lui-même.

Très sympa Robert !

Bonne journée

 

[Patrice33740]

[...]
- code Patrice :
fonctionne parfaitement.
Petite question : Est-ce à cause des used.range (pas l'habitude de les utiliser) que le code serait un peu long svp (ie : si chaque feuille 1 (par WBK rappatrié) fait plus de 25000 lignes par exemple et qu'il y a 12/15 WBK à intégrer) ?
On n'a pas le cas dans le zip joint mais c'est le cas avec mes gros fichiers à rappatrier (environ 40 secondes ce qui n'est pas long non plus -).
[...]

L'utilisation de UsedRange permet de travailler avec des fichiers données de plusieurs formats (xlx, xlsx, xlsm, ...) dans fichier cible en xlsm (avec un xls, il ne faudrait pas copier plus de 65536 lignes).

Le problème de lenteur, n'est lié à l'utilisation de UsedRange, il peut venir d'un manque de mémoire vive.
Dans tous les cas, l'affectation directe des valeurs (.value = .value) est beaucoup plus rapide que le copier / collage spécial, valeurs qui passe par le presse papier. D'autre part ce dernier peut poser problème notamment dans le cas de nombreuses copies successives (le plus sûr étant de le vider entre chaque copie)

 

[zebanx]

Merci Patrice pour ces précisions.
Bon apm.