Viết code cho bài toán đếm số lần lặp (1 người xem)

[qvtbvn8]

E có bài toán được mô tả như file ví dụ nhờ các bác GPE cho cái code chính xác giải dùm.
Xin chân thành cảm ơn

 

[Hoang2013]

Option Explicit
Sub DemSolanLap3So1LienTiep()
Dim Cls As Range, Rng As Range
Dim Lap3 As Integer, Dm As Integer, J As Integer, Dg As Integer
For Dg = 2 To 19
For Each Cls In Range(Cells(Dg, "B"), Cells(Dg, "Ar"))
If Cls.Value = 1 Then
Dm = Dm + 1
If Dm = 3 And Cls.Offset(, 1).Value <> 1 Then
Lap3 = Lap3 + 1
End If
ElseIf Cls.Value = "" Then
Dm = 0
End If
Next Cls
Cells(Dg, "AX").Value = Lap3
Lap3 = 0: Dm = 0
Next Dg
End Sub

 

[VetMini]

' hàm đếm dố lần lặp liên tiếp (lan) của một số (so) trong hàng (rg)
Function DEM(ByVal rg As Range, ByVal so As Integer, ByVal lan As Integer) As Integer
s1 = "," & Replace(Space(lan), " ", "," & CStr(so)) & ",," ' lập chuỗi nhận dạng, ví dụ số lần lặp là 3 thì chuỗi này sẽ là ",,1,1,1,,". Hai dấu phẩy liên tiếp dùng để loại trường hợp nhiều hơn 3
s2 = ",," & Replace(Join(Application.Transpose(Application.Transpose(rg)), ","), ",,", ",,,,") & ",," ' lập chuỗi cần xét, đổi ",," thành ",,,," để phòng trường hợp 2 kết quả kề nhau
DEM = (Len(s2) - Len(Replace(s2, s1, ""))) / Len(s1) ' thế chuỗi nhận dạng và đếm số lần thế
End Function

AS2 = DEM(B2:AR2, 1, 3)
AV2 = DEM(B2:AR2, 1, 2)

 

[qvtbvn8]

Option Explicit
Sub DemSolanLap3So1LienTiep()
Dim Cls As Range, Rng As Range
Dim Lap3 As Integer, Dm As Integer, J As Integer, Dg As Integer
For Dg = 2 To 19
For Each Cls In Range(Cells(Dg, "B"), Cells(Dg, "Ar"))
If Cls.Value = 1 Then
Dm = Dm + 1
If Dm = 3 And Cls.Offset(, 1).Value <> 1 Then
Lap3 = Lap3 + 1
End If
ElseIf Cls.Value = "" Then
Dm = 0
End If
Next Cls
Cells(Dg, "AX").Value = Lap3
Lap3 = 0: Dm = 0
Next Dg
End Sub

Còn trường 2 sao bác ơi?

 

[qvtbvn8]

' hàm đếm dố lần lặp liên tiếp (lan) của một số (so) trong hàng (rg)
Function DEM(ByVal rg As Range, ByVal so As Integer, ByVal lan As Integer) As Integer
s1 = "," & Replace(Space(lan), " ", "," & CStr(so)) & ",," ' lập chuỗi nhận dạng, ví dụ số lần lặp là 3 thì chuỗi này sẽ là ",,1,1,1,,". Hai dấu phẩy liên tiếp dùng để loại trường hợp nhiều hơn 3
s2 = ",," & Replace(Join(Application.Transpose(Application.Transpose(rg)), ","), ",,", ",,,,") & ",," ' lập chuỗi cần xét, đổi ",," thành ",,,," để phòng trường hợp 2 kết quả kề nhau
DEM = (Len(s2) - Len(Replace(s2, s1, ""))) / Len(s1) ' thế chuỗi nhận dạng và đếm số lần thế
End Function

AS2 = DEM(B2:AR2, 1, 3)
AV2 = DEM(B2:AR2, 1, 2)

Bác cho code chuẩn coi đi. Em ngu muội biết ít.

 

[demenzizu]

Option Explicit
Sub DemSolanLap3So1LienTiep()
Dim Cls As Range, Rng As Range
Dim Lap3 As Integer, Dm As Integer, J As Integer, Dg As Integer
For Dg = 2 To 19
For Each Cls In Range(Cells(Dg, "B"), Cells(Dg, "Ar"))
If Cls.Value = 1 Then
Dm = Dm + 1
If Dm = 3 And Cls.Offset(, 1).Value <> 1 Then
Lap3 = Lap3 + 1
End If
ElseIf Cls.Value = "" Then
Dm = 0
End If
Next Cls
Cells(Dg, "AX").Value = Lap3
Lap3 = 0: Dm = 0
Next Dg
End Sub

các bạn giải thich hộ mình cos này với
Range(Cells(Dg, "B"), Cells(Dg, "Ar")

 

[VetMini]

Bác cho code chuẩn coi đi. Em ngu muội biết ít.

Bạn định nghĩa thế nào là code chuẩn rồi chúng ta sẽ nói chuyện "cho code chuẩn coi".

 

[qvtbvn8]

Bạn định nghĩa thế nào là code chuẩn rồi chúng ta sẽ nói chuyện "cho code chuẩn coi".

Theo em code chuẩn là code chạy file dữ liệu đã đưa ra. K như sự hiểu chung chung. Bài trên bác viết với mục đích phân biệt rõ ràng các trường hợp cụ thể. Nếu sai bác bỏ qua.

 

[ndu96081631]

Bác cho code chuẩn coi đi. Em ngu muội biết ít.

Tại bài 3 copy/paste lên diễn đàn nó.. nhảy loạn, tôi ghi rõ luôn cho bạn:

Function DEM(ByVal rg As Range, ByVal so As Integer, ByVal lan As Integer) As Integer
  Dim s1 As String, s2 As String
  s1 = "," & Replace(Space(lan), " ", "," & CStr(so)) & ",,"
  s2 = ",," & Replace(Join(Application.Transpose(Application.Transpose(rg)), ","), ",,", ",,,,") & ",,"
  DEM = (Len(s2) - Len(Replace(s2, s1, ""))) / Len(s1)
End Function

Nguyên văn code, chỉ sửa chỗ khai báo biến (phòng báo lỗi tùy thiết lập từng máy)

 

[qvtbvn8]

Tại bài 3 copy/paste lên diễn đàn nó.. nhảy loạn, tôi ghi rõ luôn cho bạn:

Function DEM(ByVal rg As Range, ByVal so As Integer, ByVal lan As Integer) As Integer
  Dim s1 As String, s2 As String
  s1 = "," & Replace(Space(lan), " ", "," & CStr(so)) & ",,"
  s2 = ",," & Replace(Join(Application.Transpose(Application.Transpose(rg)), ","), ",,", ",,,,") & ",,"
  DEM = (Len(s2) - Len(Replace(s2, s1, ""))) / Len(s1)
End Function

Nguyên văn code, chỉ sửa chỗ khai báo biến (phòng báo lỗi tùy thiết lập từng máy)

Cảm ơn bác! em nghĩ và chạy thử ban đầu thì hiện vẫn đếm ok. chỉ còn xác định nhưng ô cuối nên e viết bài nhờ chỉnh code cho chuẩn. cảm ơn bác!

 

[VetMini]

Tại bài 3 copy/paste lên diễn đàn nó.. nhảy loạn,

Cám ơn, mình không để ý. Quên mất vụ chuỗi dài quá lúc paste bị web page nó tự động ngắt, chèn thêm dấu cách.

 

[qvtbvn8]

các bác coi xem code trên của bác vietmini thiếu gì chỉ giúp em.