Suppresion de filtres dans macro existante
Bonjour le forum !
J'ai un tout petit topic pour vous, je n'y connais toujours pas grand chose en VBA et j'ai beau avoir testé toutes les solutions possible, ça ne fonctionne pas...
Je cherche à intégrer quelques lignes dans une macro existante.... La macro que Banzai64 m'a faite la semaine dernière fonctionne très bien quand le tableau de base ne comprend pas de filtres, mais à partir du moment où il y en a un... Ca ne fonctionne plus :-/
Voilà ce que je souhaite intégrer comme code pour supprimer les filtres de la feuille "Hiérarchisation_AE" :
On Error Resume Next
ActiveSheet.ShowAllDataEt voila la macro avec laquelle j'aimerai bien l'associer, sachant qu'elle est positionnée sur le feuille nomme "Synthèse" :
Sub Recopie()
Dim J As Long, NbLg As Long
Dim F1 As Worksheet, F2 As Worksheet
Application.ScreenUpdating = False
Set F1 = Sheets("Hiérarchisation_AE")
Set F2 = Sheets("Synthèse")
If F2.Range("A10") <> "" Then
F2.Range("A10:AN" & F2.Range("A" & Rows.Count).End(xlUp).Row).ClearContents
End If
If F2.Range("BA10") <> "" Then
F2.Range("B10:BE" & F2.Range("BA" & Rows.Count).End(xlUp).Row).ClearContents
End If
F1.Range("N33:BA" & F1.Range("N" & Rows.Count).End(xlUp).Row).Copy
F2.Range("A10").PasteSpecial Paste:=xlPasteValues
NbLg = F2.Range("A" & Rows.Count).End(xlUp).Row
F2.Range("A10:AN" & NbLg).Sort Key1:=F2.Range("AN10"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
F2.Range("R2").Formula = "=AN10>='" & F1.Name & "'!$BB$28"
F2.Range("A9:AN" & NbLg).AdvancedFilter Action:=xlFilterCopy, criteriarange:=F2.Range("R1:R2"), copytorange:=F2.Range("BA9:BE9")
F2.Range("R2").ClearContents
NbLg = F2.Range("BA" & Rows.Count).End(xlUp).Row
If NbLg > 10 Then
With Range("BF10:BF" & NbLg)
.FormulaR1C1 = "=RC[-4]&RC[-3]&RC[-2]&RC[-1]"
.Value = .Value
End With
F2.Range("BA10:BF" & NbLg).Sort Key1:=F2.Range("BF10"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For J = NbLg To 11 Step -1
If F2.Range("BF" & J) = F2.Range("BF" & J - 1) Then
F2.Range("BA" & J - 1) = F2.Range("BA" & J - 1) & vbLf & F2.Range("BA" & J)
F2.Range("BA" & J).Resize(1, 6).Delete shift:=xlShiftUp
End If
Next J
F2.Range("BF10:BF" & NbLg).ClearContents
F2.Columns("BA:BE").AutoFit
End If
Application.ScreenUpdating = True
End SubSi quelqu'un veut bien jeter un oeil à mon problème, je lui en serais très reconnaissante !
Merci d'avance !
Bonjour
Rajoutes la ligne surlignée
If F2.Range("BA10") <> "" Then
F2.Range("B10:BE" & F2.Range("BA" & Rows.Count).End(xlUp).Row).ClearContents
End If
If F1.FilterMode = True Then F1.ShowAllData
F1.Range("N33:BA" & F1.Range("N" & Rows.Count).End(xlUp).Row).CopyUne fois de plus la solution au premier essai !
Merci !