Xin giúp đỡ: Đếm số ngày xuất hiện liên tiếp

[tranquangdiep]

Chào các bác,
Em có vấn đề cần đếm số ngày xuất hiện liên tiếp nhau trong năm của 1 cột dữ liệu mong các bác giúp đỡ.
Dữ liệu của em nằm từ cột A đến cột E. Em muốn đếm số ngày xuất hiện liên tiếp (cột G) và trả về kết quả tại cột I; Ngoài ra cứ 2 ngày liên tiếp là 1 đợt, nên em cũng muốn đếm số đợt xuất hiện và trả về cột J.
Cụ thể e để trong file đính kèm.
Mong các bác giúp đỡ ạ

 

[HUONGHCKT]

Chào các bác,
Em có vấn đề cần đếm số ngày xuất hiện liên tiếp nhau trong năm của 1 cột dữ liệu mong các bác giúp đỡ.
Dữ liệu của em nằm từ cột A đến cột E. Em muốn đếm số ngày xuất hiện liên tiếp (cột G) và trả về kết quả tại cột I; Ngoài ra cứ 2 ngày liên tiếp là 1 đợt, nên em cũng muốn đếm số đợt xuất hiện và trả về cột J.
Cụ thể e để trong file đính kèm.
Mong các bác giúp đỡ ạ

Nếu là đếm số lần có 2 ngày liên tiếp liền kề và đếm số lần có số ngày cách nhau>=2 thì thử code nay xem sao.

Sub DEM()
Dim i&, j&, Lr&, R&, D&, t&, k&
Dim Arr(), Nam(), KQ()
With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("B2:D" & Lr).Value
Nam = .Range("H2:H47").Value
R = UBound(Arr): D = UBound(Nam)
End With
ReDim KQ(1 To D, 1 To 2)
On Error Resume Next
For i = 1 To D
    For j = 1 To R
        If Nam(i, 1) = Arr(j, 1) Then
            If Arr(j, 1) = Arr(j + 1) And Arr(j, 2) = Arr(j + 1, 2) Then
                If Arr(j + 1, 3) - Arr(j, 3) = 1 Then t = t + 1: KQ(i, 1) = t
                If Arr(j + 1, 3) - Arr(j, 3) >= 2 Then k = k + 1: KQ(i, 2) = k
            End If
        End If
    Next j
    t = 0: k = 0
Next i
Sheet1.Range("I2").Resize(D, 2) = KQ
MsgBox "Xong"
End Sub

 

[HieuCD]

Chào các bác,
Em có vấn đề cần đếm số ngày xuất hiện liên tiếp nhau trong năm của 1 cột dữ liệu mong các bác giúp đỡ.
Dữ liệu của em nằm từ cột A đến cột E. Em muốn đếm số ngày xuất hiện liên tiếp (cột G) và trả về kết quả tại cột I; Ngoài ra cứ 2 ngày liên tiếp là 1 đợt, nên em cũng muốn đếm số đợt xuất hiện và trả về cột J.
Cụ thể e để trong file đính kèm.
Mong các bác giúp đỡ ạ

Chạy code

Option Explicit
Sub XYZ()
  Dim sArr(), res(), fDay$, dot&, ng&, sRow&, i&, k&
 
  With Sheet1
    sArr = .Range("B1:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim res(1 To sRow, 1 To 3)
  For i = 2 To sRow
    sArr(i, 2) = CLng(DateValue(sArr(i, 1) & "/" & sArr(i, 2) & "/" & sArr(i, 3)))
  Next i
  sArr(sRow + 1, 2) = sArr(sRow, 2) + 9999
  For i = 2 To sRow
    If sArr(i, 1) <> sArr(i - 1, 1) Then
      k = k + 1:      res(k, 1) = sArr(i, 1)
      ng = 1:         fDay = sArr(i, 3)
    ElseIf sArr(i, 2) = sArr(i - 1, 2) + 1 Then
      ng = ng + 1
    Else
      ng = 1:      fDay = sArr(i, 3)
    End If
    If sArr(i, 2) < sArr(i + 1, 2) - 1 Then
      If ng > 1 Then
        dot = dot + 1
        res(k, 2) = res(k, 2) & "," & ng & "(" & fDay & "-" & sArr(i, 3) & ")"
      End If
    End If
    If sArr(i, 1) <> sArr(i + 1, 1) Then
      If dot > 0 Then res(k, 3) = dot
      dot = 0
      res(k, 2) = Mid(res(k, 2), 2, 100)
    End If
  Next i
  Sheet1.Range("H2").Resize(k, 3) = res
End Sub

 

[tranquangdiep]

Chạy code

Option Explicit
Sub XYZ()
  Dim sArr(), res(), fDay$, dot&, ng&, sRow&, i&, k&
 
  With Sheet1
    sArr = .Range("B1:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim res(1 To sRow, 1 To 3)
  For i = 2 To sRow
    sArr(i, 2) = CLng(DateValue(sArr(i, 1) & "/" & sArr(i, 2) & "/" & sArr(i, 3)))
  Next i
  sArr(sRow + 1, 2) = sArr(sRow, 2) + 9999
  For i = 2 To sRow
    If sArr(i, 1) <> sArr(i - 1, 1) Then
      k = k + 1:      res(k, 1) = sArr(i, 1)
      ng = 1:         fDay = sArr(i, 3)
    ElseIf sArr(i, 2) = sArr(i - 1, 2) + 1 Then
      ng = ng + 1
    Else
      ng = 1:      fDay = sArr(i, 3)
    End If
    If sArr(i, 2) < sArr(i + 1, 2) - 1 Then
      If ng > 1 Then
        dot = dot + 1
        res(k, 2) = res(k, 2) & "," & ng & "(" & fDay & "-" & sArr(i, 3) & ")"
      End If
    End If
    If sArr(i, 1) <> sArr(i + 1, 1) Then
      If dot > 0 Then res(k, 3) = dot
      dot = 0
      res(k, 2) = Mid(res(k, 2), 2, 100)
    End If
  Next i
  Sheet1.Range("H2").Resize(k, 3) = res
End Sub

Em cảm ơn bác.!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!