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

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

Marsh Posté le 24-11-2006 à 17:07:17    

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
 

Reply

Marsh Posté le 24-11-2006 à 17:07:17   

Reply

Marsh Posté le 24-11-2006 à 17:16:33    

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
Reply

Marsh Posté le 24-11-2006 à 17:27:14    

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)
 
 
 

Reply

Marsh Posté le 24-11-2006 à 17:47:22    

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 :)  !!!

Reply

Marsh Posté le 24-11-2006 à 18:07:07    

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

Reply

Marsh Posté le 27-11-2006 à 10:43:15    

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
Reply

Marsh Posté le 27-11-2006 à 11:47:22    

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
Reply

Marsh Posté le 27-11-2006 à 14:13:18    

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
Reply

Marsh Posté le 27-11-2006 à 14:50:01    

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

Reply

Marsh Posté le 27-11-2006 à 16:08:13    

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
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed