1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
| Option Explicit
Sub ExtractDatas()
Dim r As Range
Dim Source As Range
Dim Target As Range
Dim Pos1 As Long
Dim CountOf As Long
Application.ScreenUpdating = False
CreateFilterTable
Set Source = Range("t_données[#all]")
For Each r In Range("t_pays")
Set Target = CopyAndGetTarget(Source)
Pos1 = Application.Match(r.Value, Target.ListObject.ListColumns(1).DataBodyRange, 0)
CountOf = Application.CountIfs(Target.ListObject.ListColumns(1).DataBodyRange, r.Value)
If Pos1 = 1 Then
DeleteLastBlock Target, CountOf
Else
DeleteFirstBlock Target, Pos1
If CountOf < Target.ListObject.ListRows.Count Then
DeleteLastBlock Target, CountOf
End If
End If
SaveAndClose Target, r.Value, ThisWorkbook.Path
Next
Application.ScreenUpdating = True
End Sub
Sub DeleteLastBlock(Target As Range, CountOf As Long)
Target(CountOf + 2, 1).Resize(Target.ListObject.ListRows.Count - CountOf, Target.Columns.Count).Delete
End Sub
Sub DeleteFirstBlock(Target As Range, Pos1 As Long)
Target(2, 1).Resize(Pos1 - 1, Target.Columns.Count).Delete
End Sub
Sub CreateFilterTable()
If Not Range("t_pays").ListObject.DataBodyRange Is Nothing Then Range("t_Pays").ListObject.DataBodyRange.Delete
Range("t_Données[Pays]").Copy Destination:=Range("t_Pays")
Range("t_pays").RemoveDuplicates 1, xlGuess
End Sub
Function CopyAndGetTarget(Source As Range) As Range
Dim wb As Workbook
Set wb = Workbooks.Add()
Set CopyAndGetTarget = wb.Worksheets(1).Range("a1")
Source.Copy Destination:=CopyAndGetTarget
With CopyAndGetTarget.ListObject.Sort
.SortFields.Clear
.SortFields.Add CopyAndGetTarget, xlSortOnValues, xlAscending
.Apply
End With
Set CopyAndGetTarget = CopyAndGetTarget.Resize(, CopyAndGetTarget.ListObject.ListColumns.Count)
End Function
Sub SaveAndClose(Target As Range, Name As String, Path As String)
Dim Filename As String
Filename = Path & "\" & Name & ".xlsx"
If Dir(Filename) <> "" Then Kill Filename
Target.Parent.Parent.Close True, Filename
End Sub |
Partager