Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
1707 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  [VBA - Excel] Copie de cellules entre 2 classeurs (moyen plus rapide?)

 
 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

[VBA - Excel] Copie de cellules entre 2 classeurs (moyen plus rapide?)

n°1481460
daboos
Posté le 24-11-2006 à 17:07:17  profilanswer
 

Bonjour tout le monde
 
J'ai écris une macro qui va chercher des cellules dans un classeur pour les recopier dans un autre classeur. Le problème c'est que ya plein de cellules à copier et que je suis débutant. Résultat : ca prend très longtemps, ma macro tourne une minute pour scanner les 30 onglets de mon classeur et récupérer les cellules voulues.
 
Je pense que ca vient du fait que j'utilise le code suivant pour aller chercher ma cellule : je suis dans mon classeur de donnéees, je copie, j'ouvre essai.xls, je colle, puis je réouvre le premier, je copie...etc...
 

Code :
  1. For l = 1 to 30
  2. For i = 1 to 250
  3.         Cells(i, NumCol).Select
  4.         Selection.Copy
  5.         Windows("essai.xls" ).Activate
  6.         Sheets(2).Select
  7.         Cells(j, 2).Select
  8.         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  9.         :=False, Transpose:=False
  10.         Windows(NomFichierOrigine & ".xls" ).Activate
  11.         Sheets(l).Select
  12. next i
  13. next l


 
En fait je sais pas s'il est possible de faire référence au texte d'une cellule d'un autre classeur sans passer par copier/coller.
 
Est-ce que quelqu'un aurait une idée pour que ca aille plus vite?  
 
Merci d'avance pour votre aide  :)  
 
Bonne soirée à tous
 
DaBoos
 

mood
Publicité
Posté le 24-11-2006 à 17:07:17  profilanswer
 

n°1481474
galopin01
Posté le 24-11-2006 à 17:16:33  profilanswer
 

bonjour,
ce code est incomplet donc on ne va pas pouvoir te dire grand chose sinon qu'il faut l'optimiser.
Les Select et autres Activate non pas lieu d'être dans une une telle macro.
Il faut utiliser une syntaxe directe qui ne sélecte et n'active rien
A la hache et avec le pied ça donne :
Workbooks("blabla" ).Worksheets(x).Range(Cells(a,b),Cells(c,d)).Copy Workbooks("cible" ).Worksheets(y).Range("A1" )
Gain de temps garanti par le remboursement de la différence...
 
A+


Message édité par galopin01 le 25-11-2006 à 03:38:48
n°1481480
aprilthe5i​th
Posté le 24-11-2006 à 17:27:14  profilanswer
 

Bonjour,
 
Tu n'as pas besoin de sélectionner les cellules avant de les copier, ni même de sélectinner la destination.
 
Il faut préalablement nommer tes classeur :
 
dim Wbk1 as workbook, Wbk2 as workbook
 
'Si tes classeurs sont fermés
Set Wbk1 = Workbooks.Open(Filename:="C:\blabla\Classeur1.xls" )
Set Wbk2 = Workbooks.Open(Filename:="C:\blabla\Classeur2.xls" )
 
'Ou bien Set Wbk1 = ThisWorkbook, si le classeur est celui ou se trouve ton code
 
 
et ensuite tu fais tes collages de type :
 
Wbk2.worksheets(K).cells(A,B)=Wbk1.worksheets(M).cells(C,D)
 
 
 

n°1481492
daboos
Posté le 24-11-2006 à 17:47:22  profilanswer
 

ca va effectivement beaucoup plus vite, c'est presque instantané!!!
 
par contre ca fait buger quelque chose dans le reste de mon prog... jvais essayer de régler ca.
 
merci beaucoup en tous cas :)  !!!

n°1481499
daboos
Posté le 24-11-2006 à 18:07:07  profilanswer
 

Re,
 
j'ai bien galéré et j'ai pas trouvé ce qui faisait bugger la suite de mon prog (une boucle qui "oublie" de se faire, sans déclencher d'erreur...). Je reviens lundi pour donner des détails, ca peut peut-être intéresser quelqu'un.
 
Bon weekend à vous deux

n°1482132
daboos
Posté le 27-11-2006 à 10:43:15  profilanswer
 

Salut,  
 
Je n'ai toujours pas trouvé ce qui faisait bugger ma macro. Voila les 2 versions, celle avec la syntaxe moche mais qui marche, et l'autre avec la syntaxe la plus directe, mais que j'arrive pas à faire tourner :(  
 


Sub ExtractionDonnees4()  
Dim SearchString As String  
Dim SearchChar As String  
Dim MyPos As Integer  
j = 2  
 
NomFichierOrigine = "Opt_Stand_Tertiaire_CEE"  
Workbooks.Open FileName:="C:\Documents and Settings\ba\Bureau\laboratoire excel\" & NomFichierOrigine & ".xls"  
Windows(NomFichierOrigine & ".xls" ).Activate  
 
 
For l = 3 To 29  
    Sheets(l).Select  
    Rows("7:20" ).Select  
    With Selection  
    Set C = .Find("Cumul", LookIn:=xlValues, MatchCase:=False)  
    Columns(C.Column).Select  
    NumCol = C.Column  
 
 
    For i = 14 To 260  
       
        If Cells(i, C.Column) > 0 Then  
         
            ' copie de la case contenant le numéro du département  
            Cells(i, 3).Select  
            Selection.Copy  
            Windows("essai.xls" ).Activate  
            Sheets(2).Select  
            Cells(j, 1).Select  
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _  
            :=False, Transpose:=False  
            Windows(NomFichierOrigine & ".xls" ).Activate  
            Sheets(l).Select  
             
            ' copie de la case correspondant au nombre d'opération ou unité utilisée (m2, m, logements,...)  
            Cells(i, NumCol).Select  
            Selection.Copy  
            Windows("essai.xls" ).Activate  
            Sheets(2).Select  
            Cells(j, 2).Select  
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _  
            :=False, Transpose:=False  
            Windows(NomFichierOrigine & ".xls" ).Activate  
            Sheets(l).Select  
             
            ' copie de la case correspondant au nombre de kWh  
            Cells(i + 1, NumCol).Select  
            Selection.Copy  
            Windows("essai.xls" ).Activate  
            Sheets(2).Select  
            Cells(j, 3).Select  
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _  
            :=False, Transpose:=False  
            Windows(NomFichierOrigine & ".xls" ).Activate  
            Sheets(l).Select  
             
            ' copie du nom de la fiche  
            Cells(4, 4).Select  
            Selection.Copy  
            Windows("essai.xls" ).Activate  
            Sheets(2).Select  
            Cells(j, 4).Select  
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _  
            :=False, Transpose:=False  
            Windows(NomFichierOrigine & ".xls" ).Activate  
            Sheets(l).Select  
             
            i = i + 1  
            j = j + 1  
           
        End If  
    Next i  
    End With  
 
Next l  
 
 
Windows("essai.xls" ).Activate  
Sheets(2).Select  
 
For K = 2 To j - 1  
    SearchString = Cells(K, 1).Text  
    SearchChar = "("  
    MyPos = InStr(1, SearchString, SearchChar, 0)  
 
'si la case est vide on est à la fin des données extraites donc fin de boucle  
    If Cells(K, 1).Text = "" Then  
        K = j - 1  
     
'si la case ne commence pas par une parenthèse alors la ligne ne nous intéresse pas, on la supprime  
    ElseIf MyPos <> 1 Then  
        Rows(K).Select  
        Selection.Delete Shift:=xlUp  
        K = K - 1  
     
'si la 4eme case est vide, les données viennent d'un onglet de synthèse qui ne nous intéresse pas, on supprime la ligne  
    ElseIf Cells(K, 4).Text = "" Then  
        Rows(K).Select  
        Selection.Delete Shift:=xlUp  
        K = K - 1  
     
' si ca commence par une parenthèse, ca nous intéresse, on prends le numéro du département dans la parenthèse  
    Else: Cells(K, 1) = Mid(Cells(K, 1).Text, 3, 3)  
 
    End If  
     
Next K  
 
Sheets(2).Select  
Cells(1, 1).Select  
Windows(NomFichierOrigine).Visible = False  
 
End Sub  


 
et voila celui avec les liens copies directes :  


Sub ExtractionDonnees3()  
Dim SearchString As String  
Dim SearchChar As String  
Dim MyPos As Integer  
j = 2  
NomFichierOrigine = "Opt_Stand_Tertiaire_CEE"  
Windows(NomFichierOrigine & ".xls" ).Activate  
Dim Wbk1 As Workbook, Wbk2 As Workbook  
Set Wbk1 = ThisWorkbook  
Set Wbk2 = Workbooks.Open(FileName:="C:\Documents and Settings\ba\Bureau\laboratoire excel\" & NomFichierOrigine & ".xls" )  
 
 
 
For l = 3 To 29  
Windows(NomFichierOrigine & ".xls" ).Activate  
Wbk2.Sheets(l).Select  
Rows("7:20" ).Select  
With Selection  
Set C = .Find("Cumul", LookIn:=xlValues, MatchCase:=False)  
Columns(C.Column).Select  
NumCol = C.Column  
 
 
For i = 14 To 260  
   
    If Cells(i, C.Column) > 0 Then  
        ' copie de la case contenant le numéro du département  
        Wbk1.Worksheets(2).Cells(j, 1) = Wbk2.Worksheets(l).Cells(i, 3)  
         
        ' copie de la case correspondant au nombre d'opération ou unité utilisée (m2, m, logements,...)  
        Wbk1.Worksheets(2).Cells(j, 2) = Wbk2.Worksheets(l).Cells(i, NumCol)  
         
        ' copie de la case correspondant au nombre de kWh  
        Wbk1.Worksheets(2).Cells(j, 3) = Wbk2.Worksheets(l).Cells(i + 1, NumCol)  
         
        ' copie du nom de la fiche  
        Wbk1.Worksheets(2).Cells(j, 4) = Wbk2.Worksheets(l).Cells(4, 4)  
         
        i = i + 1  
        j = j + 1  
       
    End If  
Next i  
End With  
 
Next l  
 
 
Windows("essai.xls" ).Activate  
Sheets(2).Select  
 
For K = 2 To j - 1  
 
    SearchString = Cells(K, 1).Text  
    SearchChar = "("  
    MyPos = InStr(1, SearchString, SearchChar, 0)  
     
    'si la case est vide on est à la fin des données extraites donc fin de boucle  
    If Cells(K, 1).Text = "" Then  
    K = j - 1  
         
    'si la case ne commence pas par une parenthèse alors la ligne ne nous intéresse pas, on la supprime  
    ElseIf MyPos <> 1 Then  
        Rows(K).Select  
        Selection.Delete Shift:=xlUp  
        K = K - 1  
         
    'si la 4eme case est vide, les données viennent d'un onglet de synthèse qui ne nous intéresse pas, on supprime la ligne  
    ElseIf Cells(K, 4).Text = "" Then  
        Rows(K).Select  
        Selection.Delete Shift:=xlUp  
        K = K - 1  
         
    ' si ca commence par une parenthèse, ca nous intéresse, on prends le numéro du département dans la parenthèse  
    Else: Cells(K, 1) = Mid(Cells(K, 1).Text, 3, 3)  
     
    End If  
Next K  
 
Sheets(2).Select  
Cells(1, 1).Select  
Windows(NomFichierOrigine).Visible = False  
 
 
End Sub  


 
Please help... je comprends pas du tout pourquoi ca ne marche plus :(


Message édité par daboos le 27-11-2006 à 14:15:13
n°1482184
kiki29
Posté le 27-11-2006 à 11:47:22  profilanswer
 

Utilise le balisage Fixed plutot que Cpp ( avec une syntaxe correcte ) cela nous permettra un copier/coller plus facile pour tester ton code.


Message édité par kiki29 le 27-11-2006 à 11:53:55
n°1482288
daboos
Posté le 27-11-2006 à 14:13:18  profilanswer
 

désolé je suis vraiment nouveau sur le forum... c'est quoi la syntaxe correcte?
 
edit : j'ai fait une modif au dessus, ca va bien comme ca ou faut-il que je change autre chose?


Message édité par daboos le 27-11-2006 à 14:16:36
n°1482324
seniorpapo​u
Posté le 27-11-2006 à 14:50:01  profilanswer
 

Bonjour,
Dans la première version copy  puis pastespecial  avec xlvalues
Il y avait peut-être une raison.?
Cordialement
 
 

n°1482391
daboos
Posté le 27-11-2006 à 16:08:13  profilanswer
 

Salut à tous
 
j'ai rajouté .Value à la fin des WbkN.worksheets(K).cells(A,B), plus quelques bidouiles d'indices et ca marche nickel :)
 
grand merci à tous !!
 
ps : voila le code qui marche au cas ou ca intéresserait qqn
 
 


Sub ExtractionDonnees3()
Dim SearchString As String
Dim SearchChar As String
Dim MyPos As Integer
j = 2
NomFichierOrigine = "blabla"
Dim Wbk1 As Workbook, Wbk2 As Workbook
Set Wbk1 = ThisWorkbook
Set Wbk2 = Workbooks.Open(FileName:="C:\Documents and Settings\ba\Bureau\laboratoire excel\" & NomFichierOrigine & ".xls" )
 
For l = 3 To 29
Windows(NomFichierOrigine & ".xls" ).Activate
Wbk2.Sheets(l).Select
Rows("7:20" ).Select
With Selection
Set C = .Find("Cumul", LookIn:=xlValues, MatchCase:=False)
Columns(C.Column).Select
NumCol = C.Column
 
 
For i = 14 To 260
 
    If Cells(i, C.Column) > 0 Then
       
        Wbk1.Worksheets(3).Cells(j, 1).Value = Wbk2.Worksheets(l).Cells(i, 3).Value
         
        Wbk1.Worksheets(3).Cells(j, 2).Value = Wbk2.Worksheets(l).Cells(i, NumCol).Value
         
        Wbk1.Worksheets(3).Cells(j, 3).Value = Wbk2.Worksheets(l).Cells(i + 1, NumCol).Value
         
        Wbk1.Worksheets(3).Cells(j, 4).Value = Wbk2.Worksheets(l).Cells(4, 4).Value
         
        i = i + 1
        j = j + 1
       
    End If
Next i
End With
 
Next l
 
Windows("essai.xls" ).Activate
Sheets(3).Select
 
For k = 2 To j - 1
 
    SearchString = Cells(k, 1).Text
    SearchChar = "("
    MyPos = InStr(1, SearchString, SearchChar, 0)
     
    'si la ligne est vide on est à la fin des données extraites donc fin de boucle
        If Cells(k, 1).Text = "" And Cells(k, 2).Text = "" And Cells(k, 3).Text = "" And Cells(k, 4).Text = "" Then
    k = j - 1
     
    'si la case ne commence pas par une parenthèse alors la ligne ne nous intéresse pas, on la supprime
    ElseIf MyPos <> 1 Then
        Rows(k).Select
        Selection.Delete Shift:=xlUp
        k = k - 1
         
    'si la 4eme case est vide, les données viennent d'un onglet de synthèse qui ne nous intéresse pas, on supprime la ligne
    ElseIf Cells(k, 4).Text = "" Then
        Rows(k).Select
        Selection.Delete Shift:=xlUp
        k = k - 1
         
    ' si ca commence par une parenthèse, ca nous intéresse, on prends le numéro du département dans la parenthèse
    Else: Cells(k, 1) = Mid(Cells(k, 1).Text, 3, 3)
     
    End If
Next k
 
CopieTableau  'copie vers un fichier d'archivage
 
End Sub
 


Message édité par daboos le 27-11-2006 à 17:09:59

Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  [VBA - Excel] Copie de cellules entre 2 classeurs (moyen plus rapide?)

 

Sujets relatifs
JAVA, XML, Excel je suis perdu[VBA] Word Commentaires
[Excel] je bloque sur un tout ptit trucVBA - Worksheet_Change ancienne valeur de la cellule
VB- comment extraire l'année d'une date au format jj/mm/aaaa de excelVBA - Adresse imprimante
Perdu le code de protection d'une macro VBA (Excel) ... Une solution ?Défi pour les pros : importer des données excel vers access...
[VBA WORD] Virer le debut des titres 
Plus de sujets relatifs à : [VBA - Excel] Copie de cellules entre 2 classeurs (moyen plus rapide?)

Forum MesDiscussions.Net, Version 2010.2
(c) 2000-2011 Doctissimo
Page générée en 0.035 secondes

Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR