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
' & .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
' & .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
' & 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