Option Explicit
Public Tg As String
Sub GPE()
Dim Dic As Object
Dim I As Long, J As Long, K As Long
Dim Tmp As String
Dim Arr, dArr, MON As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Range(Sheets("DATA").[D8], Sheets("DATA").[D65000].End(3))
ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For I = 1 To UBound(Arr, 1)
Tmp = Month(Arr(I, 1))
If Not .Exists(Tmp) Then
K = K + 1
.Add Tmp, K
For J = 1 To UBound(Arr, 2)
dArr(K, J) = Month(Arr(I, J))
Next J
End If
Next I
End With
Sheets("DATA").Range("S8").Resize(K, UBound(Arr, 2)) = dArr
Sheets("DATA").Range("R8:R" & Sheets("DATA").[D65000].End(3).Row).FormulaR1C1 = "=MONTH(RC[-14])"
Sheets("DATA").Range("S8:S" & Sheets("DATA").[S65000].End(3).Row).Name = "MON"
On Error Resume Next
For I = 1 To Range("MON").Count
Tg = Range("MON").Cells(I, 1)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Tg
Sheets("DATA").Range("A7:R" & Sheets("DATA").[D65000].End(3).Row).AutoFilter 18, Tg
Sheets("DATA").Range("A6:Q" & Sheets("DATA").[D65000].End(3).Row).SpecialCells(12).Copy Sheets(Tg).[A6]
Application.CutCopyMode = False
Next I
Sheets("DATA").AutoFilterMode = False
Sheets("DATA").Range("R8:S100").ClearContents
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
