Đếm theo điều kiện

  • Thread starter Thread starter rosy84
  • Ngày gửi Ngày gửi
Liên hệ QC
R

rosy84

Thành viên hoạt động
Tham gia
15/3/09
Bài viết
170
Được thích
38
Đếm theo điều kiện LWA và WP đựoc coi là giống nhau Nếu nó liên tiếp nhau thì hiển thị kết quả.là tổng của những ô có dữ liệu
Nếu mà cứ cách 1 ô thì lại có 1 ô có kết quả là LWA hoặc WP thì ghi lại là 1 Những thứ còn lại thì không quan tâm.
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Lúc trước em gửi nhầm bài giờ em đã up file khác mong các anh chị giúp cho.

Em nghĩ và đã dùng thử vòng lặp for rồi, nhưng không lấy giá trị các lần đếm được;

Em đang cần nó mong các anh chị bớt thời gian giúp em!

Thanks!
 
Upvote 0
rosy84 đã viết:
Đếm theo điều kiện LWA và WP đựoc coi là giống nhau Nếu nó liên tiếp nhau thì hiển thị kết quả.là tổng của những ô có dữ liệu
Nếu mà cứ cách 1 ô thì lại có 1 ô có kết quả là LWA hoặc WP thì ghi lại là 1 Những thứ còn lại thì không quan tâm.
Nhấp chuột vào đây để mở rộng...
Nếu trong một hàng có nhiều vùng có dữ liệu liên tục như vậy thì trả về kết quả nào. Ví dụ dữ liệu như thế này:
|WP|WP|LWA|||LWA|WP|WP|WP
 
Upvote 0
trả về là 4 bác à. còn nếu cách nhau 1 ô lại có 1 ô thì trả về là 1
 
Upvote 0
rosy84 đã viết:
trả về là 4 bác à. còn nếu cách nhau 1 ô lại có 1 ô thì trả về là 1
Nhấp chuột vào đây để mở rộng...
Vậy qui tắc ở đây là gì?
1. Lấy kết quả là vùng dữ liệu liên tục lớn nhất
2. Lấy kết quả là vùng dữ liệu liên tục cuối cùng
3. ...
Bạn cần nói rõ tất cả các trường hợp để khỏi mất công.
 
Upvote 0
Bạn thử kiểm tra theo file đính kèm xem sao

PHP: 
Option Explicit
Sub DemLWA_WP()
  Dim Rng As Range, Clls As Range, Rng0 As Range, Rng9 As Range
  Dim lRow As Long, Jj As Long, Dem As Byte, Max_ As Byte, MyColor As Byte
  Const W1 As String = "LWA":       Const W2 As String = "WP"
 
 Application.ScreenUpdating = False
   lRow = Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
 MyColor = [A5].Interior.ColorIndex + 1
 Columns("A:A").Interior.ColorIndex = 0
 For Jj = 6 To lRow
   Set Rng = Range(Cells(Jj, 2), Cells(Jj, 255).End(xlToLeft))
   Dem = 0
   For Each Clls In Rng
      With Clls
         If .Value <> "" And (InStr(.Value, W1) > 0 Or InStr(.Value, W2) > 0) Then
            Dem = Dem + 1:                   If Max_ < Dem Then Max_ = Dem
            Cells(Jj, 1).Value = Max_
            Cells(Jj, 1).Interior.ColorIndex = 34 + Jj Mod 7
         ElseIf .Value = "" Or InStr(.Value, W1) = 0 Or InStr(.Value, W2) = 0 Then
            If Max_ < Dem Then Max_ = Dem
            Dem = 0
         End If
      End With
   Next Clls
   If Max_ > 0 Then
      Cells(Jj, 1).Value = Max_:             Max_ = 0
   End If
 Next Jj
 [A5].Interior.ColorIndex = IIf(MyColor > 41, 34, MyColor)
End Sub
 

File đính kèm

Upvote 0
Em cũng làm được rồi, giờ up lên mọi người xem rồi góp ý cho em nha.
Sub Run()
i = [b5].End(xlLeftToRight).Column: j = [a5].End(xlDown).Row
dem1 = 0: tem = 0: dem2 = 0: k = 1: Dim sta As Integer: sta = 0
For jj = 6 To j
For ii = 3 To i
If (Cells(jj, ii) = "WP" Or Cells(jj, ii) = "LWA") And dem1 = 0 Then
If (Cells(jj, ii + 1) = "WP") _
Or (Cells(jj, ii + 1) = "LWA") Then
sta = sta + 1
ElseIf Cells(jj, ii + 1) <> "WP" _
Or Cells(jj, ii + 1) <> "WP" Then
Cells(2, k).Value = sta + 1
k = k + 1
sta = 0
ElseIf (Cells(jj, ii) = "WP" Or Cells(jj, ii) = "LWA") _
And (Cells(jj, ii + 1) <> "WP" Or Cells(jj, ii + 1) <> "LWA") _
And (Cells(jj, ii - 1) <> "WP" And Cells(jj, ii - 1) <> "LWA") Then
Cells(2, k).Value = 1
k = k + 1
End If
'If (Cells(jj, ii + 1) <> "WP" Or Cells(jj, ii + 1) <> "LWA") Then
'Cells(2, k) = sta
'sta = 0
'End If
End If
Next
dem1 = 0
k = 1
sta = 0
Cells(jj, 2) = Maxf
'Range("A2:AE2").Select
'Selection.Delete Shift:=xlToLeft
Range("A2:AE2").Select
Selection.ClearContents
Next
End Sub

Function Maxf() As Integer
Min = 0
i = [A2].End(xlLeftToRight).Column
If i = 256 Then i = 1
For ii = 1 To i
If Cells(2, ii) >= Min Then
Min = Cells(2, ii)
End If
Next
Maxf = Min
End Function
 

File đính kèm

Upvote 0
rosy84 đã viết:
Em cũng làm được rồi, giờ up lên mọi người xem rồi góp ý cho em nha.
PHP: 
Sub Run()
i = [b5].End(xlLeftToRight).Column: j = [a5].End(xlDown).Row
dem1 = 0: tem = 0: dem2 = 0: k = 1: Dim sta As Integer: sta = 0
    For jj = 6 To j
        For ii = 3 To i
            If (Cells(jj, ii) = "WP" Or Cells(jj, ii) = "LWA") And dem1 = 0 Then
                If (Cells(jj, ii + 1) = "WP") _
                   Or (Cells(jj, ii + 1) = "LWA") Then
                    sta = sta + 1
                    ElseIf Cells(jj, ii + 1) <> "WP" _
                           Or Cells(jj, ii + 1) <> "WP" Then
                            Cells(2, k).Value = sta + 1
                           k = k + 1
                           sta = 0
                ElseIf (Cells(jj, ii) = "WP" Or Cells(jj, ii) = "LWA") _
                   And (Cells(jj, ii + 1) <> "WP" Or Cells(jj, ii + 1) <> "LWA") _
                   And (Cells(jj, ii - 1) <> "WP" And Cells(jj, ii - 1) <> "LWA") Then
                   Cells(2, k).Value = 1
                   k = k + 1
                End If
                'If (Cells(jj, ii + 1) <> "WP" Or Cells(jj, ii + 1) <> "LWA") Then
                  'Cells(2, k) = sta
                   'sta = 0
                'End If
            End If
         Next
         dem1 = 0
         k = 1
         sta = 0
         Cells(jj, 2) = Maxf
         'Range("A2:AE2").Select
        'Selection.Delete Shift:=xlToLeft
        Range("A2:AE2").Select
    Selection.ClearContents
    Next
End Sub
Mã: 
Function Maxf() As Integer
Min = 0
i = [A2].End(xlLeftToRight).Column
If i = 256 Then i = 1
For ii = 1 To i
    If Cells(2, ii) >= Min Then
      Min = Cells(2, ii)
    End If
Next
  Maxf = Min
End Function
Nhấp chuột vào đây để mở rộng...

Biến i của bạn luôn = 30
Cho nên vòng lặp bên trong luôn chạy từ đầu đến cuối mỗi hàng
Nếu trước vòng lặp này, bạn xác định lại số ô cần khảo sát trong hàng (Có nghĩa là bỏ bớt, không khảo sát các ô trống cuối hàng) thì cải thiện fần nào về tốc độ.
Vế các xác định ố ô cần khảo sát trong 1 hàng ta tham khảo bài trên liền kề. Đó là câu lệnh
Mã: 
 Set Rng = Range(Cells(Jj, 2), Cells(Jj, 255).End(xlToLeft))
Mình xin đề nghị bạn tự dịch các dòng lệnh của bài trên để tự rút ra những điều dù là không nhiều, nhưng cũng thú vị.

Chúc vui!
 
Upvote 0
rosy84 đã viết:
Em cũng làm được rồi, giờ up lên mọi người xem rồi góp ý cho em nha.
Sub Run()
i = [b5].End(xlLeftToRight).Column: j = [a5].End(xlDown).Row
dem1 = 0: tem = 0: dem2 = 0: k = 1: Dim sta As Integer: sta = 0
For jj = 6 To j
For ii = 3 To i
If (Cells(jj, ii) = "WP" Or Cells(jj, ii) = "LWA") And dem1 = 0 Then
If (Cells(jj, ii + 1) = "WP") _
Or (Cells(jj, ii + 1) = "LWA") Then
sta = sta + 1
ElseIf Cells(jj, ii + 1) <> "WP" _
Or Cells(jj, ii + 1) <> "WP" Then
Cells(2, k).Value = sta + 1
k = k + 1
sta = 0
ElseIf (Cells(jj, ii) = "WP" Or Cells(jj, ii) = "LWA") _
And (Cells(jj, ii + 1) <> "WP" Or Cells(jj, ii + 1) <> "LWA") _
And (Cells(jj, ii - 1) <> "WP" And Cells(jj, ii - 1) <> "LWA") Then
Cells(2, k).Value = 1
k = k + 1
End If
'If (Cells(jj, ii + 1) <> "WP" Or Cells(jj, ii + 1) <> "LWA") Then
'Cells(2, k) = sta
'sta = 0
'End If
End If
Next
dem1 = 0
k = 1
sta = 0
Cells(jj, 2) = Maxf
'Range("A2:AE2").Select
'Selection.Delete Shift:=xlToLeft
Range("A2:AE2").Select
Selection.ClearContents
Next
End Sub

Function Maxf() As Integer
Min = 0
i = [A2].End(xlLeftToRight).Column
If i = 256 Then i = 1
For ii = 1 To i
If Cells(2, ii) >= Min Then
Min = Cells(2, ii)
End If
Next
Maxf = Min
End Function
Nhấp chuột vào đây để mở rộng...
Nếu lấy giá trị lớn nhất của vùng dữ liệu thoả điều kiện liên tục thì tôi có 2 cách như thế này:
Duyệt từ đầu đến cuối vùng dữ liệu:
PHP: 
Function Maxf1(Rng As Range) As Integer
Dim Tam As Integer
For Each Cll In Rng
If Cll.Value = "LWA" Or Cll.Value = "WP" Then
    Tam = Tam + 1
    If Tam > Maxf1 Then Maxf1 = Tam
Else
    Tam = 0
End If
Next
End Function
Chuyển về chuỗi và xử lý trên chuổi, duyệt qua số lần là kết quả trả về:
PHP: 
Function Maxf(Rng As Range) As Integer
Dim Str As String, FStr As String
Str = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Rng)))
Str = Replace(Replace(Str, "WP", vbBack), "LWA", vbBack)
FStr = vbBack
Do Until InStr(Str, FStr) = 0
    Maxf = Maxf + 1
    FStr = FStr & " " & vbBack
Loop
End Function
Đây là file test
 

File đính kèm

Upvote 0
Mình cải tiến code tại #6 & thời lượng giảm hơn 1 nữa

PHP: 
Option Explicit
Sub DemLWA_WP()
  Dim Rng As Range, Clls As Range, Rng0 As Range, Rng9 As Range
  Dim lRow As Long, Jj As Long, Dem As Byte, Max_ As Byte, MyColor As Byte
  Const W1 As String = "LWA":       Const W2 As String = "WP"
  Dim Timer_ As Double
 
 Application.ScreenUpdating = False
   lRow = Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
 MyColor = [A5].Interior.ColorIndex + 1
 Columns("A:A").Interior.ColorIndex = 0
 Timer_ = Timer()
 For Jj = 6 To lRow
   Set Rng = Range(Cells(Jj, 2), Cells(Jj, 255).End(xlToLeft))
   With Application.WorksheetFunction
1      If .CountIf(Rng, "*" & "W" & "?") > 0 Then   '<=|'
         Dem = 0
         For Each Clls In Rng
            With Clls
2               If .Value <> "" And InStr(.Value, "W") > 0 Then   '<=|'
                  Dem = Dem + 1:             If Max_ < Dem Then Max_ = Dem
4 '                  Cells(Jj, 1).Value = Max_     '
                  Cells(Jj, 1).Interior.ColorIndex = 34 + Jj Mod 7
3               ElseIf .Value = "" Or InStr(.Value, "W") = 0 Then   '<=|'
                  If Max_ < Dem Then Max_ = Dem
                  Dem = 0
               End If
            End With
         Next Clls
         If Max_ > 0 Then
            Cells(Jj, 1).Value = Max_:       Max_ = 0
         End If
      End If
   End With
 Next Jj
 [A2] = Timer() - Timer_
 [A5].Interior.ColorIndex = IIf(MyColor > 41, 34, MyColor)
End Sub
 
Upvote 0
OK, thanks các bác nha, qua đây em thấy học được nhiều điều hơn và kiến thức hơn.

Giờ em muốn đếm ngược lại mong các bác giúp em với, giống như bác huuthang_bd viết vậy.

Em có đính kèm file đay. Thanks!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
rosy84 đã viết:
OK, thanks các bác nha, qua đây em thấy học được nhiều điều hơn và kiến thức hơn.

Giờ em muốn đếm ngược lại mong các bác giúp em với, giống như bác huuthang_bd viết vậy.

Em có đính kèm file đay. Thanks!
Nhấp chuột vào đây để mở rộng...
Trường hợp này đơn giản hơn. Bạn có thể làm như thế này:
PHP: 
Function MyCount(Rng As Range) As Integer
For i = Rng.Cells.Count To 1 Step -1
    If Rng.Cells(1, i).Value = "WP" Or Rng.Cells(1, i).Value = "LWA" Then
        MyCount = MyCount + 1
    Else
        Exit For
    End If
Next
End Function
 
Upvote 0
OK, thanks bác nha, nhhững hàm đó thật là tiện dụng!
 
Upvote 0
Còn đây là macro chỉ dùng 1/5 thời gian so với #4

PHP: 
Option Explicit
Sub DemLWA_WP()
  Dim Rng As Range, Clls As Range, sRng As Range, fRng As Range
  Dim Dem As Byte, Max_ As Byte, MyColor As Byte, So1 As Byte
  Dim Jj As Long, lRow As Long, Timer_ As Double
 
 Application.ScreenUpdating = False
   lRow = Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
 MyColor = [A5].Interior.ColorIndex + 1
 Columns("A:A").Interior.ColorIndex = 0:                    Timer_ = Timer()
 For Jj = 6 To lRow
   Set fRng = Rows(Jj).Find("W", , xlFormulas, xlPart)
   If Not fRng Is Nothing Then
      Set Rng = Range(fRng.Offset(, -1), Cells(Jj, 255).End(xlToLeft))
      With Application.WorksheetFunction
         So1 = .CountIf(Rng, "*" & "W" & "?")
      End With
      If So1 = 1 Then
         Max_ = 1
      ElseIf So1 = 2 Then
         Set sRng = Rng.Find("W", , , xlPart)
         If InStr(sRng.Offset(, 1).Value, "W") = 0 Then Max_ = 1 Else Max_ = 2
      ElseIf So1 > 2 Then
         Dem = 0
         For Each Clls In Rng
            With Clls
               If .Value <> "" And InStr(.Value, "W") > 0 Then
                  Dem = Dem + 1:             If Max_ < Dem Then Max_ = Dem
                  Cells(Jj, 1).Interior.ColorIndex = 34 + Jj Mod 7
               ElseIf .Value = "" Or InStr(.Value, "W") = 0 Then
                  If Max_ < Dem Then Max_ = Dem
                  Dem = 0
               End If
            End With
         Next Clls
      End If
      If Max_ > 0 Then
         Cells(Jj, 1).Value = Max_:       Max_ = 0
      End If
   End If
 Next Jj
 [A2] = Timer() - Timer_
 [A5].Interior.ColorIndex = IIf(MyColor > 41, 34, MyColor)
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

N
Tính tổng với điều kiện gần đúng
Trả lời
3
Đọc
22
HUONGHCKT
H
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
0
Đọc
13
cuongtri
C
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
71
Đọc
10K
HeSanbi
HeSanbi
Bùi Thúy Thúy
  • Question Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
63
Đọc
19K
Mutants Men
M
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
304
Đọc
21K
axa00000019
axa00000019
Anxseo
  • Đã khóa
Cách crack my excel
Trả lời
1
Đọc
74
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
5
Đọc
219
yaaasoo01
Y
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
vc_đi chơi
Khóa Hoặc mã hóa File excel có độ bảo mật cao
    • Cảm ơn
    • Thích
Trả lời
3
Đọc
157
Hoangkhang01213
Hoangkhang01213
VietHoangPhan
Excel lỗi không hiển thị dữ liệu, dãn dòng tất cả các file
Trả lời
2
Đọc
34
VietHoangPhan
VietHoangPhan
V
  • Question Question
Tách số liệu từ bảng tính ngang theo điều kiện
Trả lời
13
Đọc
275
HieuCD
H
F
Ẩn công thức trong Google Sheets
Trả lời
2
Đọc
38
FATA11
F
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
2
Đọc
78
Phuocam
Phuocam
minhquipk
  • Question Question
Cách nhận biết những ô đã bị thay đổi giá trị khi thay đổi giá trị dữ liệu ở những ô khác
Trả lời
3
Đọc
89
le_vis
L
H
Tìm kết quả trả về theo loại
Trả lời
9
Đọc
92
VetMini
V
LongHoang123
  • Question Question
Xin hướng dẫn: Cách tạo vùng in dựa trên dữ liệu của listbox bằng VBA!!!
Trả lời
4
Đọc
101
LongHoang123
LongHoang123
M
  • Question Question
"thủ tục để xóa dòng trống " trong Lập trình VBA trong Excel
2 3 4
Trả lời
63
Đọc
15K
SonBDND
S
Q
Hỏi về công thức dò giá
Trả lời
6
Đọc
198
thanthanhan0801
T
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
6
Đọc
333
nguyenhuong34
nguyenhuong34
ThanhPhongDN
hỏi về cách thay đổi giá trị một ô sau khi nhập một giá trị vào đó
Trả lời
7
Đọc
144
vietduc147258
V
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom