Sub count() Dim i As Long Dim j As Long Dim lastrow As Long Dim ctr As Long lastrow = Range("D12").End(xlDown).Row For i = 12 To lastrow Cells(i, .Value = DateAdd("d", 30, Cells(i, 4).Value) Next For i = 12 To lastrow j = lastrow Do While Cells(i, .Value <> Cells(j, 4).Value j = j - 1 If j = 0 Then Exit Sub Loop Do While ctr < 4 If InStr(1, Cells(j - 1, 7).Value, "病院", 1) = 0 Then ctr = ctr + 1 End If j = j - 1 Loop Cells(i, 11).Value = Sheets("Sheet1").Cells(j, 4).Value ctr = 0 Next End Sub
