Bon matin à tous,
J'ai une super formule VBA qui scinde mon document en plusieurs onglets (gracieuseté de COusin Hub.... MErci encore)
Je désirerais changer la formule qui était SUM (R4C:R[-1]C) pour SUBTOTAL(9;R4C:R[-1]C)
Je croyais que c'était OK mais elle bloque à chaque fois, ce doit être simple mais je ne vois pas avec mes yeux de débutant.
Code: Tout sélectionner
Sub scinder()
Dim Cel As Range, Plg As Range
Dim DerLig As Long
Dim Numeros As Object
Dim Sh As Worksheet, FBase As Worksheet, FModele As Worksheet
Dim It As Variant
Set FBase = Sheets("base")
Set FModele = Sheets("modele")
Set Numeros = CreateObject("Scripting.Dictionary")
t = Timer
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
For Each Sh In Sheets
If Sh.Name <> FBase.Name And Sh.Name <> FModele.Name Then
Sh.Delete
End If
Next Sh
With FBase
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row
Set Plg = .Range("A3:AB" & DerLig)
For Each Cel In .Range("A4:A" & DerLig)
If Cel.Value <> "" Then
Cel.Value = Format(Trim(Cel.Value), "0000")
Numeros(Cel.Value) = Cel.Value
End If
Next Cel
End With
For Each It In Numeros.Items
FModele.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = It
FBase.Range("BA4").FormulaR1C1 = "=RC1=" & It
Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FBase.Range("BA3:BA4"), _
CopyToRange:=.Range("A3:AB3"), Unique:=False
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row + 2
With .Cells(DerLig, "L")
.FormulaR1C1 = "=SUBTOTAL(9;R4C:R[-1]C)"
.AutoFill Destination:=.Resize(1, 17)
End With
End With
Next It
FBase.Range("BA4").ClearContents
FBase.Select
MsgBox Timer - t
End Sub