Dim B As Worksheet
Dim O As Worksheet
Dim TV As Variant
Dim NL As Integer
Dim NC As Byte
Dim D As Object
Dim TMP As Variant
Dim I As Integer
Dim J As Byte
Dim K As Integer
Dim L As Integer
Dim TL() As Variant
Dim OD As Worksheet
Dim Da As Long
Set B = Worksheets("Bal Stat")
For Each O In Sheets
Application.DisplayAlerts = False
If Not O.Name = "Bal Stat" Then O.Delete
Application.DisplayAlerts = True
Next O
TV = B.Range("A1").CurrentRegion
NL = UBound(TV, 1)
NC = UBound(TV, 2)
Set D = CreateObject("Scripting.Dictionary")
For I = 2 To NL
D(TV(I, 5)) = ""
Next I
TMP = D.Keys
For L = 0 To UBound(TMP)
K = 1
For I = 1 To NL
If TV(I, 5) = TMP(L) Then
ReDim Preserve TL(1 To NC, 1 To K)
For J = 1 To NC
TL(J, K) = TV(I, J)
If J = 16 Then Da = DateSerial(Year(TV(I, J)), Month(TV(I, J)), Day(TV(I, J))): TL(J, K) = Da
Next J
K = K + 1
End If
Next I
If K > 1 Then
Worksheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = TMP(L)
Set OD = ActiveSheet
B.Rows(1).Copy OD.Range("A1")
OD.Range("A1").Resize(1, NC).Value = Application.Index(TV, 1)
OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
OD.Columns(16).NumberFormat = "dd/mm/yy"
End If
Next L
End Sub