Прогнать на дубли и исправить

[doober]

Игорь,это я менял для проверки,поставил несуществующую дату.Наблюдательный

[doober]

Sub Start()
Dim Diapazon As String
 Dim M_Path As String, SSL As String, SSL2 As String
 M_Path = ThisWorkbook.Path & "\"
 Dim RRz, L As Long, n As Long, m As Long
Application.ScreenUpdating = False
L = ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
Diapazon = "A1:V" & L
ThisWorkbook.Worksheets(1).Range(Diapazon).AutoFilter
    ActiveSheet.Range(Diapazon).AutoFilter Field:=22, Criteria1:=2 ' Февраль
LL = ThisWorkbook.Worksheets(1).Range(Diapazon).SpecialCells(xlCellTypeVisible)
 Dim iFRng As Range, X As Range
   With ActiveSheet
If .AutoFilterMode = True And .FilterMode = True Then
With .AutoFilter.Range.Columns(1)
Set iFRng = _
.Resize(.Rows.Count - 1).SpecialCells(xlVisible)
L = iFRng.Cells.Count
ReDim REZ(1 To L, 1 To 11)
n = 1
   For Each X In iFRng
REZ(n, 1) = X.Offset(0, 4)
REZ(n, 2) = X.Offset(0, 5)
REZ(n, 3) = X.Offset(0, 11)
REZ(n, 4) = X.Offset(0, 12)
REZ(n, 5) = X.Offset(0, 15)
REZ(n, 6) = X
REZ(n, 7) = X.Offset(0, 1)
REZ(n, 8) = X.Offset(0, 2)
REZ(n, 9) = X.Offset(0, 7)
REZ(n, 10) = X.Offset(0, 8)
REZ(n, 11) = X.Offset(0, 9)
n = n + 1
Next
For n = 2 To L
  ActiveSheet.Range(Diapazon).AutoFilter Field:=22, Criteria1:=1 ' Январь
    ActiveSheet.Range(Diapazon).AutoFilter Field:=5, Criteria1:=REZ(n, 1)
      ActiveSheet.Range(Diapazon).AutoFilter Field:=6, Criteria1:=REZ(n, 2)
    ActiveSheet.Range(Diapazon).AutoFilter Field:=12, Criteria1:=REZ(n, 3)
  ActiveSheet.Range(Diapazon).AutoFilter Field:=13, Criteria1:=REZ(n, 4)
   Set iFRng = .Resize(.Rows.Count - 1).SpecialCells(xlVisible)
  For Each X In iFRng
If X.Row <> 1 Then
 X.Offset(0, 15).Value = REZ(n, 5)
X.Offset(0, 15).Interior.ColorIndex = 12
  X.Value = REZ(n, 6)
    X.Offset(0, 1).Value = REZ(n, 7)
     X.Offset(0, 2).Value = REZ(n, 8)
    X.Offset(0, 7).Value = REZ(n, 9)
  X.Offset(0, 8).Value = REZ(n, 10)
 X.Offset(0, 9).Value = REZ(n, 11)
End If
Next: Next
ActiveSheet.Range(Diapazon).AutoFilter
End With
End If
End With
  Application.ScreenUpdating = True
End Sub

[doober]

Я понял.что сделал на оборот.январь меняю февралем.
Переделал

Sub Start()
Dim Diapazon As String
 Dim M_Path As String, SSL As String, SSL2 As String
 M_Path = ThisWorkbook.Path & "\"
 Dim RRz, L As Long, n As Long, m As Long
Application.ScreenUpdating = False
L = ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
Diapazon = "A1:V" & L
ThisWorkbook.Worksheets(1).Range(Diapazon).AutoFilter
    ActiveSheet.Range(Diapazon).AutoFilter Field:=22, Criteria1:="2"
LL = ThisWorkbook.Worksheets(1).Range(Diapazon).SpecialCells(xlCellTypeVisible)
 Dim iFRng As Range, X As Range
   With ActiveSheet
If .AutoFilterMode = True And .FilterMode = True Then
With .AutoFilter.Range.Columns(1)
Set iFRng = _
.Resize(.Rows.Count - 1).SpecialCells(xlVisible)
L = iFRng.Cells.Count
ReDim REZ(1 To L, 1 To 5)
n = 1
   For Each X In iFRng
REZ(n, 1) = X.Offset(0, 4)
REZ(n, 2) = X.Offset(0, 5)
REZ(n, 3) = X.Offset(0, 11)
REZ(n, 4) = X.Offset(0, 12)
REZ(n, 5) = X.Row
n = n + 1
Next
For n = 2 To L
  ActiveSheet.Range(Diapazon).AutoFilter Field:=22, Criteria1:=1
    ActiveSheet.Range(Diapazon).AutoFilter Field:=5, Criteria1:=REZ(n, 1)
      ActiveSheet.Range(Diapazon).AutoFilter Field:=6, Criteria1:=REZ(n, 2)
    ActiveSheet.Range(Diapazon).AutoFilter Field:=12, Criteria1:=REZ(n, 3)
  ActiveSheet.Range(Diapazon).AutoFilter Field:=13, Criteria1:=REZ(n, 4)
   
    Set iFRng = .Resize(.Rows.Count - 1).SpecialCells(xlVisible)
   Dim Y As Range
  For Each X In iFRng
If X.Row <> 1 Then
Set Y = Range("A" & REZ(n, 5))
 Y.Offset(0, 15).Value = X.Offset(0, 15).Value
  Y.Offset(0, 15).Interior.ColorIndex = 12
   Y.Value = X.Value
    Y.Offset(0, 1).Value = X.Offset(0, 1).Value
     Y.Offset(0, 2).Value = X.Offset(0, 2).Value
    Y.Offset(0, 7).Value = X.Offset(0, 7).Value
  Y.Offset(0, 8).Value = X.Offset(0, 8)
 Y.Offset(0, 9).Value = X.Offset(0, 9).Value
End If
Next: Next
ActiveSheet.Range(Diapazon).AutoFilter
End With
End If
End With
  Application.ScreenUpdating = True
End Sub