Sub laydulieu()
Dim arr, kq(1 To 10000, 1 To 3), i As Long, a As Long, b As Long, c As Double, s As String, k As Long, dic As Object, j As Integer
Dim dk As String, dem As Long, data
Set dic = CreateObject("scripting.dictionary")
With Sheets("Lich")
data = .Range("C2:Ah7").Value
For i = 2 To UBound(data)
dk = data(i, 1)
dem = 0
s = Empty
For j = 2 To UBound(data, 2)
If data(i, j) = "H" Then
dem = dem + 1
s = s & "#" & data(1, j)
End If
Next j
dic.Item(dk) = Array(dem, s & "#")
Next i
End With
With Sheets("sheet1")
arr = .Range("B2:D10").Value
For i = 1 To UBound(arr)
dk = arr(i, 3)
a = Day(DateAdd("m", 1, arr(i, 3)) - 1)
dem = dic.Item(dk)(0)
s = dic.Item(dk)(1)
c = arr(i, 2) / (a - dem)
For k = 1 To a
If InStr(1, s, "#" & k & "#") = 0 Then
b = b + 1
kq(b, 1) = arr(i, 1)
kq(b, 2) = c
kq(b, 3) = DateSerial(Year(arr(i, 3)), Month(arr(i, 3)), k)
End If
Next k
Next i
.Range("l2").Resize(b, 3).Value = kq
End With
End Sub
