abréger une parti du macro

Version imprimable

Bonjour,
je vous présente mon macro et j'aimerai raccourcir les lignes en bleu car en réalité je possède plus de 200 tableaux donc je vous laisse imaginer la taille du macro!!
si une personne aurai la solution je serai le plus heureux;)

Cordialement jérôme.

Code:

1
2
3
Sub cherche()
tablo1 = Sheets("Feuil1").Range("B6:F" & Sheets("Feuil1").Range("B65536").End(xlUp).Row)
tablo2 = Sheets("Feuil1").Range("H6:L" & Sheets("Feuil1").Range("H65536").End(xlUp).Row)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
For Each cel In Sheets("Feuil2").Range("C7:E7")
 For n = LBound(tablo1, 1) To UBound(tablo1, 1)
   If tablo1(n, 1) = cel.Value Then
     tot = tot + tablo1(n, 5)
    End If
 Next n
 For n = LBound(tablo2, 1) To UBound(tablo2, 1)
   If tablo2(n, 1) = cel.Value Then
     tot = tot + tablo2(n, 5)
    End If
 Next n
 cel.Offset(1, 0) = tot
 tot = 0
Next
End Sub

bonsoir

tout dabors pour plus de lisibilité de ton code mes le entre balise code(le #)dans la barre d'outil

ensuite en regardant ton code il y a quelque questions

regardons un peu ca les questions seront en commentaire dans ton code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub cherche()
 
'ici on prend les colonnes b a f mais la derniere ligne pris en compte c'est la 
 
'derniere en "colonne "b" est volontaire et si la b,c d ,e ou f est plus longue 'que fait 'on?????
tablo1 = Sheets("Feuil1").Range("B6:F" & Sheets("Feuil1").Range("B65536").End(xlUp).Row)
'meme question ici 
tablo2 = Sheets("Feuil1").Range("H6:L" & Sheets("Feuil1").Range("H65536").End(xlUp).Row)
For Each cel In Sheets("Feuil2").Range("C7:E7")
'sachant que une colection commence toujour par "0"lbound est il bien utile????
'et sachant que "c7:e7 " ne comporte pas le meme nombre de cllulle que la 'reference des deux "tablo" il va te manquer des cellules pour pouvoir 'comparer les données
 
'repond deja a ces question et on verra pour le reste
For n = LBound(tablo1, 1) To UBound(tablo1, 1)
 
If tablo1(n, 1) = cel.Value Then
tot = tot + tablo1(n, 5)
End If
Next n
For n = LBound(tablo2, 1) To UBound(tablo2, 1)
If tablo2(n, 1) = cel.Value Then
tot = tot + tablo2(n, 5)
End If
Next n
cel.Offset(1, 0) = tot
tot = 0
Next
End Sub

05/03/2012, 20h08
mapeh

Bonjour,

Bonjour Patrick,

La 1ère question qui me vient à l'esprit, quelle version d'Excel utilises-tu?

A la 1ère lecture de ton code, c'est du 2003 (utilisation du range B65536), mais au vu de ton énoncé (plus de 200 tableaux de 5 colonnes, soit plus de 1000 colonnes), sûrement Excel 2007 ou ultérieur.

On pourrait faire une boucle sur la création de tableau, en fonction du nombre de colonnes, et ne travailler que sur 1 tableau.

Un peu plus de précisions nous aiderait un peu plus

Bon courage
05/03/2012, 20h17
patricktoulon

re

bonsoir mapeh

qu'a tu bu ce soir? je ne suis pas l'auteur du post :lol:

hihihi au plaisir
05/03/2012, 20h29
mapeh

Re-,

Je n'ai rien bu, j'ai juste voulu séparer les formules de politesse....:roll:

Bonne soirée
05/03/2012, 20h42
patricktoulon

re

ok mapeh mais tel que tu a ecris c'est a moi que tu a repondu :)

bon pour revenir au sujet
il me viens une idée toute simple en ce qui concerne le "b65536"

pour evité de devoir modifier la macro pour 2007 ou 2003
utiliser pluto "rows.count" tout simplement

au plaisir

Re-,

@ jerleswatt

Si j'ai bien compris...

Je suis parti du principe que tes tableaux faisaient 5 colonnes, séparés par 1 colonne

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub mapeh()
Dim Totaux As Object
Dim Cel As Range, Plg As Range
Dim FSource As Worksheet
Dim I As Long, DerCol As Long
Dim Nbr
Set Totaux = CreateObject("Scripting.Dictionary")
Set FSource = Sheets("Feuil1")
Set Plg = Sheets("Feuil2").Range("C7:E7")
With FSource
    DerCol = .Cells(6, Columns.Count).End(xlToLeft).Column - 4
    For I = 2 To DerCol Step 6
        For Each Cel In .Range(.Cells(6, I), .Cells(Rows.Count, I).End(xlUp))
            Nbr = Application.Match(Cel, Plg, 0)
            If Not IsError(Nbr) Then
                Totaux(Nbr) = Totaux(Nbr) + Cel.Offset(, 4)
            End If
        Next Cel
    Next I
End With
Plg.Offset(1) = Totaux.Items
End Sub

Et que les cellules à comptabiliser étaient bien les cellules C7 à E7 de la feuille 2

Bonne soirée