Résolu COPIER / COLLER qui fait n'importe quoi ...

  • Auteur de la discussion TooEasy
  • Date de début
T

TooEasy

Nouveau membre
Bonjour à tous,

J'ai un programme provenant de l'assemblage de différents bouts de code glanés sur le Net
et quelques (rares) adaptations personnelles. Le but de ce programme est le suivant :
On ouvre un classeur - CLASSEUR.xlm - et on lance la macro. Plus tard ce sera par un bouton, pour l'instant c'est manuel.

La macro crée le fichier - FUSION.xlsx - dans le répertoire système %HOMEPATH%.
Grâce à la commande "GetOpenFileName", l'utilisateur peut sélectionner les fichiers qu'il veut concaténer ou non, dans ce cas, il sort du programme.

La macro ouvre donc le fichier SOURCE et le fichier CIBLE et normalement devrait copier/coller les feuilles SOURCE vers les feuilles CIBLES. Et c'est là que les ennuis arrivent.

La macro le fait mais partiellement. Ainsi la première feuille contient 4 lignes alors qu'elle devrait en avoir 760.
La seconde répond aux attentes mais je n'ai pas les suivantes seulement la dernière qui correspond à la 6ème feuille du classeur SOURCE.

Ce qui revient à dire que mon COPIER/COLLER est pourri. Trois enregistreurs de macros plus tard, je ne comprends toujours pas ce qui coince. Il faut dire que je ne suis pas un as du VBA, loin s'en faut, et je suis complètement dans les choux.

Si une âme charitable (ou plusieurs) pouvait me dire la bourde que j'ai commise, j'en serai ravi. Parce qu'à force d'avoir le nez dessus je ne vois pas ce qui "coince".

En vous remerciant de bien vouloir éclairer ma lanterne et de m'accorder un peu de votre temps.

Ci-dessous le code :
Code: 
 Sub Creer_Recapitulatif()

'-------------------------------------------------------------------------------
' But :
'  Macro qui permet de copier les informations contenues dans
'  différents fichiers pour les coller dans un fichier récapitulatif
'
' Crédits :
'  Adapté par Tof d'après les scenarii de GCXL et des autres contributeurs du Web
'
'
' A voir : Les feuilles CIBLE les créer si N'EXISTE PAS
'             Voir également si elles ont le même NOM !!
'-------------------------------------------------------------------------------

Dim wbRecap As Workbook, wbSource As Workbook             ' Classeurs CIBLE, SOURCE
Dim wsRecap As Worksheet, wsSource As Worksheet           ' Feuilles en CIBLE, SOURCE
Dim vFichiers As Variant                                  ' Noms des fichiers (array)
Dim i As Integer, k As Integer
Dim rgRecap As Range                                      ' Plage où on copie les données
Dim FichierExiste As Boolean
'
' Initialisation des VARIABLES de boucles
k = 1
i = 1

PathDir = Environ("HOMEPATH")
FileCible = "C:" & PathDir & "\FUSION.xlsx"
MsgBox "Le fichier qui collecte les données s'appelle : " & Chr(13) & Chr(10) _
       & FileCible
'
' S'il a été oublié lors d'une précédente FUSION ... On le désintègre!
FichierExiste = Dir(FileCible) <> ""
If FichierExiste Then
   Kill FileCible
End If
'
' Ouverture du fichier et sauvegarde
Set wbRecap = Application.Workbooks.Add
      wbRecap.SaveAs FileCible                              ' Renommer le fichier en Chemin Absolu
'
' Ouvrir boîte de dialogue pour sélectionner les fichiers à ouvrir
     vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler")
'
' Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "Aucun fichier sélectionné : Fin du programme"
Exit Sub
End If
On Error Resume Next
 
Application.ScreenUpdating = False
'
' Boucle de CHOIX de fichier(s)
For k = 1 To UBound(vFichiers)
'
' DEBUT du COPIER / COLLER
Set wbSource = Workbooks.Open(Filename:=vFichiers(k))     ' Ouverture du classeur SOURCE
Set wbRecap = Workbooks.Open(Filename:=FileCible)         ' Ouverture du classeur CIBLE
    
For Each wsSource In wbSource.Worksheets
    Set wsRecap = wbRecap.Sheets(wsSource.CodeName)       ' Feuille CIBLE
      
    wsSource.Activate                                     ' Sélection des cellules de la feuille (C'EST A PARTIR D'ICI QUE C'EST PAS BON DU TOUT )
    wsSource.UsedRange.Copy                               ' Copie des cellules
    wbRecap.Add After:=Sheets(Sheets.Count)               ' Positionnement de la nouvelle feuille
            wsRecap.Paste
            wsRecap.Name = k & "." & i
    wsSource.Activate
        
    i = i + 1                                             'Incrémentation des feuilles (ex: 1.1, 1.2, etc.)
 Next
        
     wbSource.Close                                       'fermer classeur SOURCE
     wbRecap.Save
     wbRecap.Close                                        'fermer classeur CIBLE
Set wbRecap = Nothing
Set wbSource = Nothing

Next
' ICI, il faut faire le ménage ...

Application.ScreenUpdating = True
    
MsgBox "Fin du Programme"
 
End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
'
' bMultiSelect à True = Permet de choisir plusieurs fichiers à la fois
    bMultiSelect = True
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
    
End Function

Merci pour votre aide.
Greg.
 
jacktara

jacktara

Modérateur
Staff
Salut,

Tu peux utiliser la balise code pour afficher ton code s'il te plait? :merci:
 
T

TooEasy

Nouveau membre
bonjour Jacktara,

Désolé, c'est la première fois que je poste. Pourtant, j'avais encapsulé le code du programme avec le bouton code [Ctrl+D] qui donne
Code: 
           Programme
J'ai modifié en ajoutant [ACTIVE SCRIPT 3] mais je ne sais pas si c'est mieux - à mon avis c'est pas génial.

Merci pour ton aide,
Greg.
 
T

TooEasy

Nouveau membre
Meilleure réponse
Bonsoir,

Après quelques déboires et prises de têtes, j'ai modifié le code de la macro. C'est peut-être "bourrin" mais cela a l'énorme avantage de fonctionner. Donc voici le code définitif pour fusionner plusieurs fichiers en un seul appelé FUSION.xlsx et qui,
cerise sur le gâteau, traite n'importe quel fichier xlsx. J'ai rajouté un "sleep" car sur mon PC, Excel se perdait en chemin.
J'ai même eu peur de ne plus le revoir ...

Code: 
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Creer_Recapitulatif()

'---------------------------------------------------------------------------------
' But :
'  Macro qui permet de copier les informations contenues dans
'  différents fichiers pour les coller dans un fichier récapitulatif
'
' Crédits :
'  Adapté par Tof d'après les scenarii de GCXL et des autres contributeurs du Web
'---------------------------------------------------------------------------------

Dim wbRecap As Workbook, wbSource As Workbook              ' Classeurs CIBLE, SOURCE
Dim wsRecap As Worksheet, wsSource As Worksheet            ' Feuilles  CIBLE, SOURCE
Dim vFichiers As Variant                                   ' Noms des fichiers (array)
Dim LastLig As Long, LastCol As Long, NumCol As Long, _
    NumLig As Long, nblig As Long
Dim i As Integer, k As Integer, j As Integer, n As Integer, l As Integer
'
' Initialisation des VARIABLES de boucles
k = 1
i = 1

PathDir = Environ("HOMEPATH")
FileCible = "C:" & PathDir & "\FUSION.xlsx"
MsgBox "Le fichier qui collecte les données s'appelle : " & Chr(13) & Chr(10) _
       & FileCible
'
' S'il a été oublié lors d'une précédente FUSION ... On le désintègre!
FichierExiste = Dir(FileCible) <> ""
If FichierExiste Then
   Kill FileCible
End If
'
' Ouverture du fichier et sauvegarde
Set wbRecap = Application.Workbooks.Add
    wbRecap.SaveAs FileCible
'
' Ouvrir boîte de dialogue pour sélectionner les fichiers à ouvrir
    vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler")
'
' Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
       Debug.Print "Aucun fichier sélectionné."
       MsgBox "Aucun fichier sélectionné : Fin du programme"
Exit Sub
End If

On Error Resume Next
 
Application.ScreenUpdating = False

l = UBound(vFichiers)                                                                   'Récupère le nombre maximal de fichiers à ouvrir
'
' Boucle de CHOIX de fichier(s)
Do While k <= l
'
' DEBUT du COPIER / COLLER
  Set wbSource = Workbooks.Open(Filename:=vFichiers(k))                                 ' Ouverture du classeur SOURCE
      j = wbSource.Sheets.Count                                                         ' Nombre de feuilles du classeur SOURCE
  Set wbRecap = Workbooks.Open(Filename:=FileCible)                                     ' Ouverture du classeur CIBLE
  
  MsgBox "Fichier traité actuellement :" & vFichiers(k)
                                                      
  i = 1                                                                                 ' Démarrage à la feuille 1 du classeur SOURCE
   
  Do While i <= j
     nblig = 1                                                                          ' Pas d'incrément de ligne
     NumCol = 1                                                                         ' Initialisation de colonne
     NumLig = 1                                                                         ' Initialisation de ligne
     LastLig = wbSource.Sheets(i).Range("A1048576").End(xlUp).Row                       ' Dernière ligne de la feuille SOURCE
     LastCol = wbSource.Sheets(i).Cells(1, Cells.Columns.Count).End(xlToLeft).Column    ' Dernière colonne de la feuille SOURCE

     If k = 1 Then                                                                      ' Traitement si c'est le 1er fichier
        n = i
     Else
      
        n = wbRecap.Sheets.Count                                                        ' Pour ajouter les feuilles suivantes après les
        n = n + 1                                                                       ' feuilles.
     End If
      
     If wbRecap.Sheets(n) Is Nothing Then
        wbRecap.Sheets.Add After:=wbRecap.Sheets(Sheets.Count)
                Worksheets(n).Name = "Feuil" & n
     End If
      
     Do While nblig < LastLig
        wbRecap.Sheets(n).Cells(NumLig, NumCol).Value = wbSource.Sheets(i).Cells(NumLig, NumCol).Value
        If NumCol >= LastCol Then
           NumCol = 0
           nblig = nblig + 1
           NumLig = NumLig + 1
       End If
    NumCol = NumCol + 1
    Loop
'
' Renommage de la Feuille en cours
  wbRecap.Sheets(n).Name = k & "." & i
     
  i = i + 1
  Loop

  Sleep 1000                                             'Attente d'une seconde

  wbSource.Close                                         'fermer classeur SOURCE
  wbRecap.Save
  wbRecap.Close                                          'fermer classeur CIBLE
Set wbSource = Nothing
Set wbRecap = Nothing

k = k + 1
Loop

Application.ScreenUpdating = True
    
MsgBox "Fin du Programme"
End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
'
' bMultiSelect à True = Permet de choisir plusieurs fichiers à la fois
    bMultiSelect = True
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
    
End Function

En espérant que cela pourra aider...
Et si je peux trouver le bouton pour passer ce sujet en RESOLU, je serais heureux.

Greg.
 
jacktara

jacktara

Modérateur
Staff
Re,

C'est fait. ;)
Par contre je ne peux pas rajouter la balise code pour toi, tu peux le faire s'il te plaît? :merci:
 
T

TooEasy

Nouveau membre
Bonjour Jacktara,

La balise
Code: 
 c'est bien Ctrl+D ? Je l'ai fait : Code - Programme - /Code (j'évite les [ ] sinon cela va être interprété). Pourquoi cela ne marche pas ? Serais-je poursuivi par les démons du VBA ?

Merci d'avoir clôturé le sujet.
Bonne journée et à bientôt pour de nouvelles aventures d'Excel ... :) 

Greg.
 
jacktara

jacktara

Modérateur
Staff
Re,

Ahah, sûrement une balise qui ferme ta balise de code avant la fin ou un truc du genre.

Code: 
int main()
{
int i = 0;

for(i; i<10; i++)
printf("hola\n");
return (0);
}

les balises que j’utilise ici sont [code*] [/code*] sans les étoiles. ;)

EDIT: en voyant ce que ça donne quad je les utilises aussi je me demande si c'est juste que ce n'est pas aussi visible qu'avant. :merci:
 
drul

drul

Obscur pro du hardware
Staff
On peut très bien écrire [code] [/code] les gars ;) il y a une astuce un peu chiante mais qui marche bien (cliquer en bas sur le bouton BB pour la voir).

Sinon , quand on fait du VB, le mieux est d'utiliser la balise [code="vb"] [/code]
ça met des jolie couleurs partout :love:

Edit pour Jack, ça marche aussi avec code="c++" ;)
 
jacktara

jacktara

Modérateur
Staff
OMG, je suis mauvais. :o
Merci j'avais oublié cette feature. :merci:
 
drul

drul

Obscur pro du hardware
Staff
N.B. et le gros bonus à utiliser les balises code, c'est d'éviter de se retouver avec des smileys partout :)

Exemple sans balise :
(a:p)
Avec balise:
Code: 
(a:p)
 
T

TooEasy

Nouveau membre
Bonsoir Drul,

Un grand merci pour
Code: 
, car j'avais utilisé le Crtl+D ([code*] [/code*] pour encapsuler mon code, mais apparemment cela n'a pas fonctionné. La prochaine fois, je ne referai plus cette erreur. Je me coucherai donc moins idiot ce soir.

Et pour finaliser le code déposé :
Il faut ajouter Option Explicit
Déclarer PathDir et FileCible en Sting
             FichierExiste en Boolean

Supprimer les deux variables Worksheets qui ne sont pas utilisées.

Bonne fin de journée à toute l'équipe.
Greg.
 
drul

drul

Obscur pro du hardware
Staff
Finalement pour TooEasy:

Mais pourquoi diable copier le contenu de chaque cellule une à une ??? c'est à cause de cela que te macro prend des heures à être exécuter et que tu as du rajouter le sleep.

Code: 
For i=1 to lastLig
  For j=1 to lastCol
    dest.Cells(i,j).Value=src.Cells(i,j).Value
  next
next
Se remplace très très avantageusement par:

Code: 
 src.range(src.cells(1,1),src.cells(lastLig,lastCol).copy dest.range("A1")
 
drul

drul

Obscur pro du hardware
Staff
N.B. c'est [code="vb"] avec des guillemets hein !
 
T

TooEasy

Nouveau membre
Bonjour Drul,

Oui, désolé. J'ai confondu vitesse et précipitation. Je mettrai les guillemets. Par contre je rebondis sur ton astuce d'hier. Une fois que l'on a rajouté la parenthèse fermante après lastCol :) , nous allons nous heurter à la problématique suivante quand nous allons passer au fichier suivant : La feuille cible existera (Feuil1) et sera écrasée par la copie. Ce n'est pas bon du tout. Je me suis heurté également à la syntaxe VBA. Excel m'insulte pour certaines commandes.
Il faut dire que le VBA n'est pas mon langage de prédilection et j'ai été obligé de prendre le train en "route" avec des wagons mal accrochés d'où ce code "exotique" mais qui marche (< 1' pour deux fichiers de 1 Mo) . Il n'y a pas de quoi sauter de joie mais c'est acceptable ...

Merci pour l'astuce, je vais tâcher d'optimiser le code dès que peux.

Bonne journée à toi et à l'équipe.
Greg.
 
drul

drul

Obscur pro du hardware
Staff
Pas compris ton problème ...
il te suffit de "setter" Dest sur une autre feuille avant la copie ...
 
drul

drul

Obscur pro du hardware
Staff
amha si tu remplaces

Code: 
     Do While nblig < LastLig
        wbRecap.Sheets(n).Cells(NumLig, NumCol).Value = wbSource.Sheets(i).Cells(NumLig, NumCol).Value
        If NumCol >= LastCol Then
           NumCol = 0
           nblig = nblig + 1
           NumLig = NumLig + 1
       End If
    NumCol = NumCol + 1
Loop

par

Code: 
        wbSource.Sheets(i).UsedRange.copy wbRecap.Sheets(n).range("A1")

ça devrais bien le faire ...
 
T

TooEasy

Nouveau membre
Drul,

Un grand Merci ! Effectivement, il y a plus simple, mais quand on ne sait pas...Et je dois avouer que sur le Net, il y a des solutions mais pas les explications. Et quand on ne maîtrise pas, on se plante.
Enfin en me basant sur ton bout de code, j'ai modifié la macro. Ce qui donne :
Code: 
Sub Creer_Recapitulatf()

'---------------------------------------------------------------------------------
' But :
'  Macro qui permet de copier les informations contenues dans
'  différents fichiers pour les coller dans un fichier récapitulatif
'
' Crédits :
'  Adapté par Tof d'après les scenarii de GCXL et des autres contributeurs du Web
'---------------------------------------------------------------------------------

Dim wbRecap As Workbook, wbSource As Workbook                              ' Classeurs CIBLE, SOURCE
Dim wshs As Worksheet                                                      ' Feuille SOURCE
Dim vFichiers As Variant                                                   ' Noms des fichiers (array)
Dim LastLig As Long, LastCol As Long
Dim i As Integer, k As Integer, j As Integer
Dim PathDir As String, FileCible As String, sName As String
Dim FichierExiste As Boolean, FeuilleExiste As Boolean
'
' Initialisation des VARIABLES de boucles
k = 1
i = 1
j = 1
PathDir = Environ("HOMEPATH")
FileCible = "C:" & PathDir & "\FUSION.xlsx"
MsgBox "Le fichier qui collecte les données s'appelle : " & Chr(13) & Chr(10) _
       & FileCible
'
' S'il a été oublié lors d'une précédente FUSION ... On le désintègre!
FichierExiste = Dir(FileCible) <> ""
If FichierExiste Then
   Kill FileCible
End If
'
' Ouverture du fichier et sauvegarde
Set wbRecap = Application.Workbooks.Add
    wbRecap.SaveAs FileCible
'
' Ouvrir boîte de dialogue pour sélectionner les fichiers à ouvrir
    vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler")
'
' Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
       Debug.Print "Aucun fichier sélectionné."
       MsgBox "Aucun fichier sélectionné : Fin du programme"
Exit Sub
End If

On Error Resume Next
 
Application.ScreenUpdating = False
'
' Boucle de CHOIX de fichier(s)
For k = 1 To UBound(vFichiers)
'
' DEBUT de la COPIE
  i = 1
    
  Set wbSource = Workbooks.Open(Filename:=vFichiers(k))                    ' Ouverture du classeur SOURCE
  Set wbRecap = Workbooks.Open(Filename:=FileCible)                        ' Ouverture du classeur CIBLE
     
  MsgBox "Fichier traité actuellement :" & vFichiers(k)
  
  For Each wshs In wbSource.Sheets
      
      sName = wshs.CodeName
      LastLig = wshs.Range("A1048576").End(xlUp).Row                              ' Dernière ligne de la feuille SOURCE
      LastCol = wshs.Cells(1, Cells.Columns.Count).End(xlToLeft).Column    ' Dernière colonne de la feuille SOURCE

      On Error Resume Next
      
      wbRecap.Activate
      
      If k = 1 Then
         FeuilleExiste = Not (IsError(Evaluate("='" & sName & "'!A1")))
         If Not FeuilleExiste Then
            wbRecap.Sheets.Add.Move After:=Sheets(Sheets.Count)
         End If
      Else
           
           wbRecap.Sheets.Add.Move After:=Sheets(Sheets.Count)
      End If
      
      wbSource.Activate
  '
  ' src.range(src.cells(1,1),src.cells(lastLig,lastCol)).copy dest.range("A1")                             Drul's Tom's Hardware Hint (à adapter)
      wshs.Range(wshs.Cells(1, 1), wshs.Cells(LastLig, LastCol)).Copy wbRecap.Sheets(j).Range("A1")
  '
  ' Renommage de la Feuille en cours
      wbRecap.Sheets(j).Name = k & "." & i
      j = j + 1
      i = i + 1
  Next

  wbSource.Close                                                           'fermer classeur SOURCE
  wbRecap.Save
  wbRecap.Close                                                            'fermer classeur CIBLE
  
  Set wbSource = Nothing
  Set wbRecap = Nothing

Next

Application.ScreenUpdating = True
    
MsgBox "Fin du Programme"
End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
'
' bMultiSelect à True = Permet de choisir plusieurs fichiers à la fois
    bMultiSelect = True
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
    
End Function

Merci pour tout!
Bonne journée.
Greg
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Dernières actus
Derniers messages publiés
Statistiques globales
Discussions
730 126
Messages
6 717 807
Membres
1 586 365
Dernier membre
matiOs1
Partager cette page
Haut