Accélérer la fonction Range
Bonjour,
Je n'ai pas réussit à trouver un bon titre mais voilà le problème.
Quand je fais cette commande ...
Tableau = Range("A" & decalage, Cells(nbL + decalage, 22))
... mon fichier excel se met en "ne réponds pas" puis continue jusqu'à finir correctement le programme.
Ma question est donc : Serait-il possible d'éviter cela avec une autre function ?
ps: j'essaye de copié une partie de mon fichier excel dans un tableau
Merci pour vos futurs réponses.
Cordialement.
Bonjour,
Eh bien moi aussi je suis "en répond pas"
Faudrait peut-être voir un peu plus de ton code, voir même un bout de fichier
J'ai fais quelques tests avec des MsgBox pour voir où ça rammé, et c'est avec cette ligne là. Mais pas de soucis j'affiche le code complet et si au passage il y a quelques modification à faire
Sub Ratio_Heure()
Dim stfile, nomFichier, nbLFichier2, nbL%, nbC%, Tableau(), decalage, prov, TabFinal(), UOE, nomCourant, prenomCourant, nbPersonneDifferente, cptPersonne, verification
Dim wB As Workbook
nomFichier = ThisWorkbook.Name
stfile = Application.GetOpenFilename
If Not VarType(stfile) = vbBoolean Then
Set wB = Workbooks.Open(Filename:=stfile)
MsgBox "Vous allez travailler sur le fichier " & stfile
nbL = WorksheetFunction.CountA(Range("A:A")) + 1 ' nombre de ligne
For j = 1 To nbL
If Cells(j, 1) = "Direction" Then
decalage = j
j = nbL
End If
Next
nbL = nbL - decalage
nbC = Cells(decalage, Columns.Count).End(xlToLeft).Column ' nombre de colonne
Tableau = Range("A" & decalage, Cells(nbL + decalage, 22)) ' Tableau en entier
' effacer les cases du fichier
For i = 1 To nbL + decalage
For j = 1 To nbC
Cells(i, j).ClearContents
Next
Next
' écrire dans les cellules A1 B1 et C1
Cells(1, 1) = "Nom"
Cells(1, 2) = "Prenom"
Cells(1, 3) = "UOE"
' recopier le tableau dans les cellules
For i = 2 To nbL + 1
Cells(i, 1) = Tableau(i, 7)
Cells(i, 2) = Tableau(i, 8)
prov = CDbl(Tableau(i, 21))
Cells(i, 3) = prov
Next
' DEUXIEME ETAPE
nomCourant = " "
prenomCourant = " "
UOE = 0
nbPersonneDifferente = 0 ' nombre total de personne
cptPersonne = 1 ' compteur de personne
'trouver le nombre de personne différente
For i = 2 To nbL
If Not Cells(i, 1) = nomCourant Or Not Cells(i, 2) = prenomCourant Then
nbPersonneDifferente = nbPersonneDifferente + 1
nomCourant = Cells(i, 1)
prenomCourant = Cells(i, 2)
End If
Next
TabFinal = Range("A2", Cells(nbL + 2, 3)) ' tableau trié
nomCourant = TabFinal(1, 1)
prenomCourant = TabFinal(1, 2)
UOE = TabFinal(1, 3)
For i = 2 To nbL + 1
If TabFinal(i, 1) = nomCourant And TabFinal(i, 2) = prenomCourant Then
UOE = UOE + TabFinal(i, 3)
Else
Cells(cptPersonne + 1, 1) = nomCourant
Cells(cptPersonne + 1, 2) = prenomCourant
Cells(cptPersonne + 1, 3) = UOE
nomCourant = TabFinal(i, 1)
prenomCourant = TabFinal(i, 2)
UOE = TabFinal(i, 3)
cptPersonne = cptPersonne + 1
End If
Next
' on efface les dernières lignes inutiles
For i = cptPersonne + 1 To nbL + 1
For j = 1 To 3
Cells(i, j).ClearContents
Next
Next
' affiche la fenetre de demande du nombre de jours travaillé
Cells(2, 5) = "nbJours"
nbJours.Show
' On verifie si tout le monde a travaillé le bon nombre de jour
verification = True
For i = 1 To nbPersonneDifferente - 1
If Not Cells(i + 1, 3) = Cells(2, 6) Then
verification = False
End If
Next
'on colorie la case vert si tout le monde est ok, rouge s'il quelqu'un n'a pas fait tout les jours.
If verification Then
Workbooks(nomFichier).Sheets(2).Range("H24").Interior.Color = RGB(0, 255, 0)
Workbooks(nomFichier).Sheets(2).Range("H24").Value = "OK"
Workbooks(nomFichier).Sheets(2).Range("I24").Interior.Color = RGB(0, 255, 0)
Workbooks(nomFichier).Sheets(2).Range("I24").Value = "OK"
Else
Workbooks(nomFichier).Sheets(2).Range("H24").Interior.Color = RGB(255, 0, 0)
Workbooks(nomFichier).Sheets(2).Range("H24").Value = "KO"
Workbooks(nomFichier).Sheets(2).Range("I24").Interior.Color = RGB(255, 0, 0)
Workbooks(nomFichier).Sheets(2).Range("I24").Value = "KO"
End If
ActiveWorkbook.Close False
End If
End Sub
Je vais clore ce sujet, bizarrement ça refonctionne ... Peut être une surcharge du pc je sais pas.