Sub XapXepKV()
Dim Darr(), Arr(), Kv(), Bp1(), Bp2(), Bp3(), S, Mth As Long, Tmp As String, i As Long, Srow As Integer
Application.ScreenUpdating = False
Kv = Array(6, 13, 20, 26, 39, 48, 55, 65, 76, 82)
Darr = Range("A1:G" & Kv(9) - 2).Value2
Mth = CStr(Month(Now))
For k = 0 To UBound(Kv) - 1 Step 3
ReDim Bp1(1 To Kv(k + 1) - Kv(k) - 1, 1 To 7)
a1 = UBound(Bp1)
ReDim Bp2(1 To Kv(k + 2) - Kv(k + 1) - 1, 1 To 7)
a2 = UBound(Bp2)
ReDim Bp3(1 To Kv(k + 3) - Kv(k + 2) - 2, 1 To 7)
a3 = UBound(Bp3)
n1 = 0: n2 = 0: n3 = 0
For i = Kv(k) To Kv(k + 3) - 3
Tmp = Darr(i, 2)
If Tmp <> "" Then
S = Split(Tmp, ".")
If CStr(CLng(S(1))) = Mth Then
n3 = n3 + 1
For j = 1 To 7
Bp3(n3, j) = Darr(i, j)
Next j
Else
Tmp = Darr(i, 4) & Darr(i, 7)
If Tmp = "" Then
n2 = n2 + 1
For j = 1 To 7
Bp2(n2, j) = Darr(i, j)
Next j
Else
S = Split(Tmp, ".")
If CStr(CLng(S(1))) = Mth Then
n2 = n2 + 1
For j = 1 To 7
Bp2(n2, j) = Darr(i, j)
Next j
Else
n1 = n1 + 1
For j = 1 To 7
Bp1(n1, j) = Darr(i, j)
Next j
End If
End If
End If
End If
Next i
Range("A" & Kv(k)).Resize(UBound(Bp1), 7) = Bp1
Range("A" & Kv(k + 1)).Resize(UBound(Bp2), 7) = Bp2
Range("A" & Kv(k + 2)).Resize(UBound(Bp3), 7) = Bp3
Next k
Application.ScreenUpdating = True
End Sub
