Scinder un fichier et sous-total

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

Bonsoir

Remplace le ; par une ,

"=SUBTOTAL(9,R4C:R[-1]C)"

Amicalement

Nad

Tellement trop simple,

C'est magique les petits détails

Un GROS merci à to NAD

Débutamment

Spage

Rechercher des sujets similaires à "scinder fichier total"