Exporter les page en feuilles et tri atomatique
Bonjour;
je suis débutant en VBA et je veux réaliser une Template qui permet d'exporter chaque page d'excel (page imprimable) en feuille excel sur le même classeur et trier par la suite la première colonne par ordre croissant.
j'ai commencé par ce code, il copie le header dans chaque feuille et copie la page au dessous, sauf que le filtre automatique par colonne A ne s'effectue pas, quelqu'un peut m'aider please
Sub Create_Separate_Sheet_For_Each_HPageBreak()
Dim HPB As HPageBreak
Dim RW As Long
Dim PageNum As Long
Dim Asheet As Worksheet
Dim Nsheet As Worksheet
Dim Acell As Range
'Sheet with the data, you can also use Sheets("Sheet1")
Set Asheet = ActiveSheet
If Asheet.HPageBreaks.Count = 0 Then
MsgBox "There are no HPageBreaks"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'When the macro is ready we return to this cell on the ActiveSheet
Set Acell = Range("A1")
'Because of this bug we select a cell below your data
'http://support.microsoft.com/default.aspx?scid=kb;en-us;210663
Application.Goto Asheet.Range("A" & Rows.Count), True
RW = 1
PageNum = 1
For Each HPB In Asheet.HPageBreaks
'Add a sheet for the page
With Asheet.Parent
Set Nsheet = Worksheets.Add(after:=.Sheets(.Sheets.Count))
End With
'Give the sheet a name
On Error Resume Next
Nsheet.Name = "Page " & PageNum
If Err.Number > 0 Then
MsgBox "Change the name of : " & Nsheet.Name & " manually"
Err.Clear
End If
On Error GoTo 0
'Copy the cells from the page into the new sheet
With Asheet
.Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy _
Nsheet.Cells(1)
End With
' If you want to make values of your formulas use this line also
' Nsheet.UsedRange.Value = Nsheet.UsedRange.Value
RW = HPB.Location.Row
PageNum = PageNum + 1
Next HPB
Asheet.DisplayPageBreaks = False
Application.Goto Acell, True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Dim WS As Worksheet, Source As Worksheet
Set Source = ThisWorkbook.Sheets("1") 'Modify to suit.
Application.ScreenUpdating = False
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> Source.Name Then
Source.Rows("1:1").Copy
WS.Rows("1:1").Insert Shift:=xlDown
End If
Next WS
Application.CutCopyMode = False
Application.ScreenUpdating = True
Dim xWs As Worksheet
On Error Resume Next
For Each xWs In Worksheets
xWs.Range("A1").AutoFilter 1,
Next
End Sub