Đếm các ô liên tiếp bằng VBA (1 người xem)

[1986QV]

em có file sau mong các anh chị giúy em đếm các ô liên tiếp bằng VBA thay vì countif dùm em
Cảm ơn mọi người quan tâm!

 

[Quang_Hải]

Thử code này coi sao
Sub dem()
Application.ScreenUpdating = False
Dim i, r, k, vung
Set C = Cells
vung = UsedRange
i = UsedRange.Row
k = UBound(vung)
k = k + i - 1
For r = i To k
C(r, 14) = Application.CountBlank(Range(C(r, 1), C(r, 13)))
Next
Application.ScreenUpdating = True
End Sub

 

[1986QV]

Cảm ơn bác. Nhưng mảng của là mảng động khi thay vào lại không đúng như file sau bác xem lại dùm em.

View attachment Dem lai.xlsx

 

[thanhsangnguyen1982]

Đếm bằng VBA

Bạn xem file, có ok không

 

[ndu96081631]

Nghĩ cũng hơi mắc cười!
Đằng nào thì cũng dùng COUNTBLANK, vậy sao không gõ trực tiếp vào cell (chẳng hạn =COUNTBLANK(A1:M1) ...)
Còn nếu viết thành code VBA thì nên viết theo kiểu xử lý mảng nhầm tăng tốc độ tính toán ---> Khi ấy ta sẽ không dùng đến hàm COUNTBLANK trong code VBA
---------------
Ngoài ra xin nói ngoài lề một chút: Rõ ràng tiêu đề là Đếm các ô liên tiếp bằng VBA ---> Vậy chổ nào trong code hoặc công thức mô tả cái vụ LIÊN TIẾP kia?

 

[thanhsangnguyen1982]

Thử code này coi sao
Sub dem()
Application.ScreenUpdating = False
Dim i, r, k, vung
Set C = Cells
vung = UsedRange
i = UsedRange.Row
k = UBound(vung)
k = k + i - 1
For r = i To k
C(r, 14) = Application.CountBlank(Range(C(r, 1), C(r, 13)))
Next
Application.ScreenUpdating = True
End Sub

Code của anh quang hai chinh lại tí xíu
Sub dem()
Application.ScreenUpdating = False
Dim i, r, k, vung, c
Set c = Cells
vung = UsedRange
k = UBound(vung)
For r = 1 To k
c(r, 14) = Application.CountBlank(Range(c(r, 1), c(r, 13)))
Next
Application.ScreenUpdating = True
End Sub

 

[1986QV]

Nghĩ cũng hơi mắc cười!
Đằng nào thì cũng dùng COUNTBLANK, vậy sao không gõ trực tiếp vào cell (chẳng hạn =COUNTBLANK(A1:M1) ...)
Còn nếu viết thành code VBA thì nên viết theo kiểu xử lý mảng nhầm tăng tốc độ tính toán ---> Khi ấy ta sẽ không dùng đến hàm COUNTBLANK trong code VBA
---------------
Ngoài ra xin nói ngoài lề một chút: Rõ ràng tiêu đề là Đếm các ô liên tiếp bằng VBA ---> Vậy chổ nào trong code hoặc công thức mô tả cái vụ LIÊN TIẾP kia?

Bài em đăng có nhầm 1 chút đếm có điều kiện. Mục đích bài đếm các ô kế tiếp cuối cùng.
Bác ah đếm các ô kế tiếp nhau cuối giống 1 bài bác đã viết rồi đó (VD =COLUMN()-LOOKUP(2,1/(V5:""),COLUMN(B2:K2))-1 ). Em nảy ra ý này giảm dung lượng file và tốc độ bác ah. Thanks bác!

 

[1986QV]

em có file sau mong các anh chị giúy em đếm các ô liên tiếp bằng VBA thay vì countif dùm em
Cảm ơn mọi người quan tâm!

em xin dính chính lại file và viết code đếm ô liên tiếp cuối cùng
View attachment Dem Tu dong bang VBA.xlsx

 

[Quang_Hải]

Thử lại xem sao, cũng không biết là cuối cùng của bạn là so sánh với cột nào.

Sub Dem()
Application.ScreenUpdating = False
Dim i, r, k, j, n, vung, c
Dim Arr()
Set c = Cells
vung = UsedRange
i = UsedRange.Row
j = UBound(vung)
k = j + i - 1
ReDim Arr(1 To j, 1 To 1)
For r = i To k
n = n + 1
Arr(n, 1) = c(r, 14).Column - c(r, 14).End(1).Column
Next
Cells(i, 15).Resize(n, 1) = Arr
Application.ScreenUpdating = True
End Sub

 

[Quang_Hải]

Code của anh quang hai chinh lại tí xíu
Sub dem()
Application.ScreenUpdating = False
Dim i, r, k, vung, c
Set c = Cells
vung = UsedRange
k = UBound(vung)
For r = 1 To k
c(r, 14) = Application.CountBlank(Range(c(r, 1), c(r, 13)))
Next
Application.ScreenUpdating = True
End Sub

Chỉ sợ nếu dữ liệu không bắt đầu từ dòng 1 nên mình phải thêm i=usedrange.row

 

[ndu96081631]

em có file sau mong các anh chị giúy em đếm các ô liên tiếp bằng VBA thay vì countif dùm em
Cảm ơn mọi người quan tâm!

em xin dính chính lại file và viết code đếm ô liên tiếp cuối cùng
View attachment 83766

Thử code xem sao:
1> Hàm hổ trợ

Function LastBlanks(ByVal SrcRng As Range)
  Dim Arr(), tmpArr, tmp As String
  Dim lR As Long, lC As Long, n As Long
  On Error Resume Next
  tmpArr = SrcRng.Value
  ReDim Arr(1 To UBound(tmpArr, 1), 1 To 1)
  For lR = 1 To UBound(tmpArr, 1)
    lC = UBound(tmpArr, 2)
    tmp = CStr(tmpArr(lR, lC))
    Do While Len(tmp) = 0
      lC = lC - 1
      If lC <= 0 Then Exit Do
      tmp = CStr(tmpArr(lR, lC))
    Loop
    Arr(lR, 1) = UBound(tmpArr, 2) - lC
  Next
  LastBlanks = Arr
End Function

2> Code chính để chạy:

Sub Main()
  Dim Arr, SrcRng As Range
  Set SrcRng = Range("A1:M14")
  Arr = LastBlanks(SrcRng)
  SrcRng.Offset(, SrcRng.Columns.Count).Resize(, 1).Value = Arr
End Sub

Nếu dữ liệu khác hơn, hãy khai báo lại biến SrcRng

 

[1986QV]

Thử lại xem sao, cũng không biết là cuối cùng của bạn là so sánh với cột nào.

Sub Dem()
Application.ScreenUpdating = False
Dim i, r, k, j, n, vung, c
Dim Arr()
Set c = Cells
vung = UsedRange
i = UsedRange.Row
j = UBound(vung)
k = j + i - 1
ReDim Arr(1 To j, 1 To 1)
For r = i To k
n = n + 1
Arr(n, 1) = c(r, 14).Column - c(r, 14).End(1).Column
Next
Cells(i, 15).Resize(n, 1) = Arr
Application.ScreenUpdating = True
QUÓToQUỐTEnd Sub[/QUÓT

cuối cùng của em so với điểm cuối có số 1 và bắt đầu đếm từ đó
View attachment Dem lai.xlsx

 

[ndu96081631]

cuối cùng của em so với điểm cuối có số 1 và bắt đầu đếm từ đó

Bạn sửa code của tôi lại chút là được rồi:

Function LastBlanks(ByVal SrcRng As Range, Inc As Long)
  Dim Arr(), tmpArr, tmp As String
  Dim lR As Long, lC As Long, n As Long
  On Error Resume Next
  tmpArr = SrcRng.Value
  ReDim Arr(1 To UBound(tmpArr, 1), 1 To 1)
  For lR = 1 To UBound(tmpArr, 1)
    lC = UBound(tmpArr, 2)
    tmp = CStr(tmpArr(lR, lC))
    Do While Len(tmp) = 0
      lC = lC - 1
      If lC <= 0 Then Exit Do
      tmp = CStr(tmpArr(lR, lC))
    Loop
    Arr(lR, 1) = UBound(tmpArr, 2) - lC + Inc
  Next
  LastBlanks = Arr
End Function

Sub Main()
  Dim Arr, SrcRng As Range, Inc As Long
  Inc = 6
  Set SrcRng = Range("A1:J27")
  Arr = LastBlanks(SrcRng, Inc)
  Range("R1").Resize(UBound(Arr, 1)).Value = Arr
End Sub

Cái gia số Inc ở trên tôi cho = 6 (tức tính từ cột K đến cột P) ---> Với dữ liệu khác, bạn tự chỉnh lấy nhé

 

[1986QV]

bác [h=2]ndu96081631[/h]viết chuẩn không cần chỉnh luôn. Em có ý nếu mở rộng ra đếm các ô kê tiếp đó sau so sánh các khoảng đó max or min thì sao đây??? bài toán này nghe rất khó. Các bác thử xem sao???
Cảm ơn mọi người quan tâm!

 

[1986QV]

Bác viết lần đầu rất chuẩn chỉnh lại hỏng hay do bác hiểu nhầm ý em. Bắt đầu đếm từ điểm 1 cuối cùng từ trái qua phải liên tục không gián đoạn tại đâu như file trên. chứ không phải đếm tất cả các ô trống bác ah.
Rất cảm ơn mọi người quan tâm!
View attachment Dem Tu dong bang VBA.xlsx

 

[Ba Tê]

Bác viết lần đầu rất chuẩn chỉnh lại hỏng hay do bác hiểu nhầm ý em. Bắt đầu đếm từ điểm 1 cuối cùng từ trái qua phải liên tục không gián đoạn tại đâu như file trên. chứ không phải đếm tất cả các ô trống bác ah.
Rất cảm ơn mọi người quan tâm!
View attachment 83784

Public Function GPE(Rng As Range) As Long
Dim K As Long, Clls As Range
For Each Clls In Rng
If Clls.Value = "" Then
K = K + 1
Else
K = 0
End If
Next
GPE = K
End Function

 

[ndu96081631]

Bác viết lần đầu rất chuẩn chỉnh lại hỏng hay do bác hiểu nhầm ý em. Bắt đầu đếm từ điểm 1 cuối cùng từ trái qua phải liên tục không gián đoạn tại đâu như file trên. chứ không phải đếm tất cả các ô trống bác ah.
Rất cảm ơn mọi người quan tâm!

Hỏi lòng vòng sao lại quay về cái cũ thế này? Yêu cầu của bạn đã được giải quyết tại bài 11 rồi còn gì