Recopie ligne formules par vba et optimisation

KIM

XLDnaute Accro
Bonjour le forum.
J'utilise souvent la technique ci-dessous:
Je definis mes formules sur une ligne
et je la recopie par macro dans la plage souhaitée.
Ex:
mes formules en G2:M2 ,
la macro 'Copie_ligneformules_dansplage'
recopie et calcule chaque formule dans la plage G5:M208

Mes données reelles font presque 60 000 lignes et 50 colonnes. et le temps d'exécution est tres tres long.
Je souhaite optimiser ce code et le rendre plus rapide en utilisant les tableaux. Cela me fera gagner beaucoup de temps.
Merci de votre aide
Amicalement
KIM

Sub Copie_ligneformules_dansplage()
Dim w_nfile As String
Dim MyPath As String
Dim Ws As Worksheet
Dim n_line As Long


Set Ws = Worksheets('DATA2')

With Application
.ScreenUpdating = False
' .ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

w_nfile = ActiveWorkbook.Name
MyPath = ActiveWorkbook.Path
Ws.Activate
Ws.Select
If Ws.AutoFilterMode Then
Selection.AutoFilter
End If

Windows(w_nfile).Activate
ActiveSheet.Calculate
n_line = Ws.Range('E2')

Range('G5:M' & n_line).Select
Selection.ClearContents


Range('G2:M2').Copy Destination:=Range('G5:G' & n_line)
ActiveSheet.Calculate
With Selection
.Copy
.Calculate
' .PasteSpecial Paste:=xlFormats
.PasteSpecial Paste:=xlValues
End With

With Application
.CutCopyMode = False
.DisplayAlerts = False
.ScreenUpdating = True
' .ScreenUpdating = False
.Calculation = xlCalculationManual
End With


MsgBox 'c'est fini'
End Sub [file name=prjKIMv1.zip size=35953]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/prjKIMv1.zip[/file]
 

Pièces jointes

  • prjKIMv1.zip
    35.1 KB · Affichages: 104

KIM

XLDnaute Accro
Bonjour le fil,
Merci Bebere,
je me lève juste pour quitter le bureau et je recois ton message. Curieux, je regarde ton fichier sans attendre le lendemain. Suite à ce premier test, les resultats ne sont pas les memes en les comparants à la premiere macro. Par ex pour les codes projets 51, 52, 62, 64 et 71, les depenses globales et par DEP sont à '0'. J'ai l'impression qu'il y a un probleme de format??
Qu'en penses-tu?
Sinon, j'ai regardé ta macro, mais je n'arrive pas à comprendre. As-tu le temspd e la commenter?
Merci d'avance.
Bien amicalement
KIM
 

Bebere

XLDnaute Barbatruc
bonsoir à toutes et tous
corrigé et mis commentaires
j'ai relu le message de Jean Marie,qui m'a mis sur le bon chemin,j'ai pas dit le droit chemin
à bientôt [file name=prjKIMv42_20060516204045.zip size=41718]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/prjKIMv42_20060516204045.zip[/file]
 

Pièces jointes

  • prjKIMv42_20060516204045.zip
    40.7 KB · Affichages: 31

ChTi160

XLDnaute Barbatruc
Salut KIM
Bonsoir Bebere
Bebere je vois que tu n'as pas perdu ton temps Chapeau pour ce que tu as réalisé
je n'ai pas eu le temps encore de bien regarder le dernier fichier
mais je me suis permis de remplacer la recopie des données
'For L = 2 To UBound(Tablo, 1)
'For C = 2 To UBound(Tablo, 2)
'.Cells(L, C).Offset(3, 6).Value = Tablo(L, C)
'Next C
'Next L
par .Range('G4').Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo
nouvelle accélération lol
si tu es,comme moi un Mordu et je n'en doute pas
je pense que tu réfléchi déjà a comment,est ce possible ,peut on simplifier cette procèdure et ainsi encore gagné du temps
mais attention car bientôt la macro va avoir afficher le résultat avant de l'avoir lancé Lol
Encore Bravo Bebere,je vais regarder tout ca
Merci

Message édité par: Chti160, à: 16/05/2006 21:02
 

ChTi160

XLDnaute Barbatruc
Arfff
j'arrive plus a allèger le fichier et pourtant y reste plus rien dedans Lol
donc je joins la macro de Bebere que j'ai un peu modifié testé avec 11200 lignes 79 colonnes
et c'est pas mal
seul problème j'ai perdu la derniere ligne, tu sait,celle où y avait la Flêche Lol
mais bon on devrait la retrouver juste pour le fun comme dirait notre Ami @+Thierry
Voila la macro
Sub x()
Dim Debut As Date, NbreL As Integer
Dim Tablo As Variant, I As Integer, C As Byte, DerCol As Byte
Dim ColData As Collection, NameAddress As String, SheetName As String
Debut = Time
With Application
.ScreenUpdating = False 'True
.Calculation = xlCalculationManual 'Automatic
End With

With Sheets('data2')

'code
Tablo = .Range('D5:D' & .Range('D65536').End(xlUp).Row + 1)

DerCol = IIf(.Cells(4, 255).End(xlToLeft).Column < 7, 7, .Cells(4, 255).End(xlToLeft).Column)
.Range(.Cells(4, 7), .Cells(.Cells(65536, 7).End(xlUp).Row + 1, DerCol)).ClearContents

.Range('G4') = 'Projets'
.Range('H4') = 'Dépenses Globales'
Set ColData = New Collection 'une collection,c'est sans doublons

For I = LBound(Tablo, 1) To UBound(Tablo, 1)
On Error Resume Next
ColData.Add CStr(Tablo(I, 1)), CStr(Tablo(I, 1))
On Error GoTo 0
Next I
I = 1
For Each Item In ColData
I = I + 1
.Range('G' & I + 4) = Item
Next Item
Set ColData = Nothing

.Range('G5:G' & .Range('G65536').End(xlUp).Row + 1).Sort Key1:=.Range('G5'), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
'dep
.Range('A5:D' & .Range('A65536').End(xlUp).Row).Sort Key1:=.Range('A5'), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

Tablo = .Range('A5:A' & .Range('A65536').End(xlUp).Row + 1)

Set ColData = New Collection 'une collection,c'est sans doublons

For I = LBound(Tablo, 1) To UBound(Tablo, 1)
On Error Resume Next
ColData.Add CStr(Tablo(I, 1)), CStr(Tablo(I, 1))
On Error GoTo 0
Next I
I = 9
For Each Item In ColData
.Cells(4, I) = Item
I = I + 1
Next Item

Set ColData = Nothing
'ce qui est çi-dessus vient du code autofill
L = .Range('D65536').End(xlUp).Row ' + 1
'donne un nom aux plages de cellules
'ColA=DEP,ColB=code,ColD=les montants à sommer
'tu les retrouves dans insertion nom définir
SheetName = '=' & .Name & '!'
NameAddress = .Range('A5:A' & L).Address
ActiveWorkbook.Names.Add Name:='ColA', RefersTo:=SheetName & NameAddress

NameAddress = .Range('B5:B' & L).Address
ActiveWorkbook.Names.Add Name:='ColB', RefersTo:=SheetName & NameAddress
NameAddress = .Range('D5:D' & L).Address
ActiveWorkbook.Names.Add Name:='ColD', RefersTo:=SheetName & NameAddress

DerCol = IIf(.Cells(4, 255).End(xlToLeft).Column < 7, 7, .Cells(4, 255).End(xlToLeft).Column)
Tablo = .Range(.Cells(4, 7), .Cells(.Cells(65536, 7).End(xlUp).Row + 1, DerCol))

'Tablo = .Range('G4:O' & .Range('G65536').End(xlUp).Row + 1)

For I = 2 To UBound(Tablo, 1)
'Depenses Globales
If IsNumeric(Tablo(I, 1)) Then Tablo(I, 2) = _
Evaluate('SUM((Cold=' & Tablo(I, 1) & ')*Col'B')')
If Not IsNumeric(Tablo(I, 1)) Or IsEmpty(Tablo(I, 1)) Then _
Tablo(I, 2) = Evaluate('SUM((Cold=''' & Tablo(I, 1) & ''')*Col'B')')

'tout ce qui suit CODE PROJETS et DEP
For C = 3 To UBound(Tablo, 2)
If IsNumeric(Tablo(I, 1)) Then Tablo(I, C) = Evaluate('SUM((Cold=' & _
Tablo(I, 1) & ')*(ColA=''' & Tablo(1, C) & ''')*Col'B')')

If Not IsNumeric(Tablo(I, 1)) Or IsEmpty(Tablo(I, 1)) Then _
Tablo(I, C) = Evaluate('SUM((Cold=''' & _
Tablo(I, 1) & ''')*(ColA=''' & Tablo(1, C) & ''')*Col'B')')
Next
Next I

.Range('G4').Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo

End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
MsgBox 'temps: ' & Format(Time - Debut, 'h:m: 's')
End Sub
Arff y a des parasites Lol ColD 'B' Oter le guillemets autour des lettres en Gras Bé et estce

Message édité par: Chti160, à: 16/05/2006 23:09
 

ChTi160

XLDnaute Barbatruc
Salut KIM
Bonjour Bebere
Bonjour le Fil ,Le Forum
en pièce jointe le fichier Lol
il suffit d'ajouter des Departements et des Codes et des Sommes bien sur
Bonne journée [file name=prjKIMv44.zip size=35754]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/prjKIMv44.zip[/file]

Message édité par: Chti160, à: 17/05/2006 08:19
 

Pièces jointes

  • prjKIMv44.zip
    34.9 KB · Affichages: 32

KIM

XLDnaute Accro
Bonjour Bebere, JeanMarie
Bonjour le fil, le forum,
Merci à vous tous,
@Bebere,je savais que j'aurais une reponse à ma demande grace à toi. merci encore.
@JeanMarie, merci aussi de ta collaboration.
Je vais regarder le fichier
l'adapter à mes données et vous tenir au courant.
Bien amicalement
KIM
 

Bebere

XLDnaute Barbatruc
bonjour Kim,Jean-Marie
merçi à tous deux pour les compliments
j'ai retrouvé la flèche elle pointait sur un panneau avec le texte 'suite au prochain numéro'
cela me va le travail en groupe ça apporte un plus
je vais tester le code amélioré(sans aucun doute) de Jean-Marie
à bientôt
 

KIM

XLDnaute Accro
Bonjour Bebere, JeanMarie
Bonjour le fil, le forum,
J'apprends grace à vous et vous en remercie.
En lisant le code, si j'ai bien compris, la macro remplit directement la plage cible sans passer par les formules definies dans la ligne 2 (H2:M2).
Dans le fichier exemple les formules sont simples, et la fonction Evaluate('SUM(... repond bien à cet exemple. Dans la cas de formules plus complexes y-a-t-il moyen de modifier le code en donnant à evaluate, lors du balayage de la plage cible tablo, les formules de la ligne 2 (H2:M2)? Ne hurler pas j'espère que je ne dis pas de betises.
Merci d'avance
KIM
 

Bebere

XLDnaute Barbatruc
bonsoir à toutes et tous
explication dans le fichier
à bientôt [file name=prjKIMv44_20060517212309.zip size=42202]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/prjKIMv44_20060517212309.zip[/file]
 

Pièces jointes

  • prjKIMv44_20060517212309.zip
    41.2 KB · Affichages: 28

Bebere

XLDnaute Barbatruc
bonjour Kim,jean-Marie,le Forum
tant que la comparaison est numérique c'est ok
l'idée serait de créer 1 colonne à côté de d
numérotée ,faire extraction sans doublons
on aurait qu'une formule
qu'en pense JM si il est dans le coin
en tout cas j'essaye ce soir,maintenant devoir oblige
à bientôt
 

KIM

XLDnaute Accro
Bonjour le fil, Jean-Marie et le forum,
Bonjour Bebere,
Merci je vais regarder ta macro ce WE.
La seule question que j'ai actuellement: Est-ce que ta nouvelle methode dans cette macro est applicable à n'importe quelle type de formules à recopier?
J'ai l'impression que j'ai posé une question exotique car personne n'a réagi à part vous deux.
Merci et A bientôt
Bon WE
Bien amicalement
KIM
 

Discussions similaires

Réponses
7
Affichages
292

Statistiques des forums

Discussions
311 709
Messages
2 081 779
Membres
101 816
dernier inscrit
Jfrcs