Lọc với rất nhiều điều kiện

Liên hệ QC
H

hcl_pt

Thành viên hoạt động
Tham gia
21/10/10
Bài viết
199
Được thích
10
Chân thành mong GPE giúp mình một vấn đề về lọc với rất nhiều điều kiện mình có gửi kèm theo file! Tết cổ truyền đang đến gần ai cũng bề bộn với những công việc cuối năm nên thật mong GPE bớt chút thời gian giúp mình giải quyết vấn đề này với (Hì, hi vọng sẽ được ăn tết không phải suy nghĩ về vấn đề này)! Chúc GPE năm mới nhiều thắng lợi!

Mình thành thật xin lỗi bạn! Ở file excel trên mình dùng font chữ vntime, nay mình xin gửi lại file dùng font unicode! Chân thành cảm ơn bạn đã quan tâm!
 

File đính kèm

  • Locdulieu_tonghop.rar
    153.4 KB · Đọc: 78
Chỉnh sửa lần cuối bởi điều hành viên:
Cái nào dễ & đã cảm thấy hiểu đúng thì mần trước

PHP: 
Option Explicit
Sub FirstValueIsRows()
 Dim Timer_ As Double
 Dim Rng As Range, vlRg As Range
 Dim eRs As Long, jJ As Long, eCol As Byte, SoO As Byte
 
 Sheets("S1").Select:                           Timer_ = Timer
 Set Rng = [A4].CurrentRegion:                  eRs = Rng.Rows.Count
 eCol = Rng.Columns.Count
 For jJ = 4 To eRs
    If Cells(jJ, "B").Value <> "" Then
        Set Rng = Cells(jJ, "B")
        Set vlRg = Range(Rng, Rng.Offset(, -1).End(xlToRight))
        SoO = vlRg.Count:               vlRg.Interior.ColorIndex = 38
    End If
    Cells(jJ, "GU").Value = SoO:                SoO = 0
 Next jJ
 [GU1].Value = Timer - Timer_
End Sub
--=0 --=0 --=0
PHP: 
Sub FirstBlanksInRows()
 Dim Timer_ As Double
 Dim Rng As Range, BlRg As Range
 Dim eRs As Long, jJ As Long, eCol As Byte, SoO As Byte
  Sheets("S1").Select:                           Timer_ = Timer
 Set Rng = [A4].CurrentRegion:                  eRs = Rng.Rows.Count
 eCol = Rng.Columns.Count
 For jJ = 4 To eRs
    If Cells(jJ, "B").Value = "" Then
        Set Rng = Cells(jJ, "B")
        Set BlRg = Range(Rng, Rng.End(xlToRight).Offset(, -1))
        SoO = BlRg.Count:               BlRg.Interior.ColorIndex = 35
    End If
    Cells(jJ, "GR").Value = SoO:                SoO = 0
 Next jJ
 [GR1].Value = Timer - Timer_
End Sub


Còn 2 cái giữa chúng chưa hiểu mần răng chừ!
 
ChanhTQ@ đã viết:
PHP: 
Option Explicit
Sub FirstValueIsRows()
Dim Timer_ As Double
Dim Rng As Range, vlRg As Range
Dim eRs As Long, jJ As Long, eCol As Byte, SoO As Byte
 
Sheets("S1").Select: Timer_ = Timer
Set Rng = [A4].CurrentRegion: eRs = Rng.Rows.Count
eCol = Rng.Columns.Count
For jJ = 4 To eRs
If Cells(jJ, "B").Value <> "" Then
Set Rng = Cells(jJ, "B")
Set vlRg = Range(Rng, Rng.Offset(, -1).End(xlToRight))
SoO = vlRg.Count: vlRg.Interior.ColorIndex = 38
End If
Cells(jJ, "GU").Value = SoO: SoO = 0
Next jJ
[GU1].Value = Timer - Timer_
End Sub
--=0 --=0 --=0
PHP: 
Sub FirstBlanksInRows()
Dim Timer_ As Double
Dim Rng As Range, BlRg As Range
Dim eRs As Long, jJ As Long, eCol As Byte, SoO As Byte
Sheets("S1").Select: Timer_ = Timer
Set Rng = [A4].CurrentRegion: eRs = Rng.Rows.Count
eCol = Rng.Columns.Count
For jJ = 4 To eRs
If Cells(jJ, "B").Value = "" Then
Set Rng = Cells(jJ, "B")
Set BlRg = Range(Rng, Rng.End(xlToRight).Offset(, -1))
SoO = BlRg.Count: BlRg.Interior.ColorIndex = 35
End If
Cells(jJ, "GR").Value = SoO: SoO = 0
Next jJ
[GR1].Value = Timer - Timer_
End Sub


Còn 2 cái giữa chúng chưa hiểu mần răng chừ!
Nhấp chuột vào đây để mở rộng...

Cảm ơn bạn nhiều quá! Chờ mong mãi cuối cùng bạn đã giúp mình! Mình sẽ test thử xem! Thân ái!
- Tuyệt vời quá bạn àh! Rất đúng ý tưởng đó ạ! Như vậy tạm thời có 3 điều kiện tìm đã thực hiện được!
- Còn 3 cái nữa mình xin nói rõ hơn về điều kiện tìm:
+ Cột kết quả thứ 2: đó là tìm số ô trống liên tiếp ít nhất có trong hàng bắt đầu đếm từ cột B
+ Cột kết quả thứ 4: đó là tìm số ô có dữ liệu liên tiếp nhiều nhất có trong hàng bắt đầu đếm từ cột B
+ Cột kết quả thứ 5: đó là tìm số ô có dữ liệu liên tiếp ít nhất có trong hàng bắt đầu đếm từ cột B
- Ngoài ra mình rất thích phương án tô màu rất khoa học và tiện theo dõi!
Một lần nữa xin cảm ơn bạn! Chúc Bạn và gia đình năm mới nhiều may mắn! Chúc GPE luôn phát triển!
 
Lần chỉnh sửa cuối:
Bạn thử với macro sau xem đúng í bạn chưa nha

PHP: 
Option Explicit
Sub MinBlankRangeInRows()
 Dim eCol As Byte, eRw As Long, jJ As Long, Min_ As Byte, SoOR As Byte
 Dim RCuoi As Range, RgR As Range, lRng As Range, RDau As Range
 Dim Timer_ As Double
 On Error GoTo LoiCT
 
 Sheets("S1").Select:                           Timer_ = Timer
 Set RCuoi = [B2].CurrentRegion
 eCol = RCuoi.Columns.Count:                     eRw = RCuoi.Rows.Count
 
 For jJ = 4 To eRw
    Min_ = eCol
    If Cells(jJ, "B").Value = "" Then
        Set RCuoi = Cells(jJ, "a")
    Else
        Set RCuoi = Cells(jJ, "A").End(xlToRight)
    End If
   Do
        Set RDau = RCuoi.End(xlToRight) ' Xac Dinh O Co Tri Tiep theo'
        
        If RDau.Column > eCol Or RCuoi.Column > eCol Then
            RgR.Interior.colorinex = 36:        Set lRng = Nothing
            Min_ = eCol:                        Exit Do
        End If
        
        Set RgR = Range(RCuoi.Offset(, 1), RDau.Offset(, -1)) 'Cac O Rong'
        SoOR = RgR.Count
        If SoOR = 1 Then
            RgR.Interior.ColorIndex = 36
5            If Not lRng Is Nothing Then Set lRng = Nothing
            Min_ = eCol:                        Exit Do
        ElseIf SoOR > 1 Then
            If SoOR < Min_ Then
                Min_ = SoOR:                    Set lRng = RgR
            End If
        End If
        
        If RDau.Offset(, 1).Value = "" Then
            Set RCuoi = RDau
        Else
            Set RCuoi = RDau.End(xlToRight)
        End If
   Loop
 Next jJ
 [gq1].Value = Timer - Timer_
 
Err_:                   Exit Sub
LoiCT:
    MsgBox Erl, , Err & ": " & Error
    Resume Err_
End Sub
Chúc xuân vui vẽ! --=0 --=0 --=0
 
HYen17 đã viết:
PHP: 
Option Explicit
Sub MinBlankRangeInRows()
Dim eCol As Byte, eRw As Long, jJ As Long, Min_ As Byte, SoOR As Byte
Dim RCuoi As Range, RgR As Range, lRng As Range, RDau As Range
Dim Timer_ As Double
On Error GoTo LoiCT

Sheets("S1").Select: Timer_ = Timer
Set RCuoi = [B2].CurrentRegion
eCol = RCuoi.Columns.Count: eRw = RCuoi.Rows.Count

For jJ = 4 To eRw
Min_ = eCol
If Cells(jJ, "B").Value = "" Then
Set RCuoi = Cells(jJ, "a")
Else
Set RCuoi = Cells(jJ, "A").End(xlToRight)
End If
Do
Set RDau = RCuoi.End(xlToRight) ' Xac Dinh O Co Tri Tiep theo'

If RDau.Column > eCol Or RCuoi.Column > eCol Then
RgR.Interior.colorinex = 36: Set lRng = Nothing
Min_ = eCol: Exit Do
End If

Set RgR = Range(RCuoi.Offset(, 1), RDau.Offset(, -1)) 'Cac O Rong'
SoOR = RgR.Count
If SoOR = 1 Then
RgR.Interior.ColorIndex = 36
5 If Not lRng Is Nothing Then Set lRng = Nothing
Min_ = eCol: Exit Do
ElseIf SoOR > 1 Then
If SoOR < Min_ Then
Min_ = SoOR: Set lRng = RgR
End If
End If

If RDau.Offset(, 1).Value = "" Then
Set RCuoi = RDau
Else
Set RCuoi = RDau.End(xlToRight)
End If
Loop
Next jJ
[gq1].Value = Timer - Timer_

Err_: Exit Sub
LoiCT:
MsgBox Erl, , Err & ": " & Error
Resume Err_
End Sub
Chúc xuân vui vẽ! --=0 --=0 --=0
Nhấp chuột vào đây để mở rộng...

Vâng! Cảm ơn bạn!
- Bạn ơi! Mình đã test code nhưng Cột kết quả thứ 2: "đó là tìm số ô trống liên tiếp ít nhất có trong hàng bắt đầu đếm từ cột B" không có kết quả? Code mới chỉ có tô màu thôi ạ!
- Mong bạn kiểm tra lại giúp mình có phải như vậy không nhé?
- Chúc bạn một tết vui vẻ! Thân ái!
 
Tại anh tại ả, tại cả đôi đường!

Mình đã test code nhưng Cột kết quả thứ 2: "đó là tìm số ô trống liên tiếp ít nhất có trong hàng bắt đầu đếm từ cột B" không có kết quả? Code mới chỉ có tô màu thôi ạ! Thân ái!
Nhấp chuột vào đây để mở rộng...

Vì số ô trống liên tiếp ít nhứt của các hàng đều là 1, nên mình nghĩ không cần fải ghi lại làm chi đó nha!

Nếu bạn ghi là: "Tìm cột đầu tiên trong hàng mà có số ô rỗng liên tiếp ít nhứt" thì mình sẽ làm khác như file đính kèm dưới đây.

Nhưng dòng 50 trong nớ mình đã sửa lại để chương trình cho thẩy các đáp án 1 cách tổng quát hơn.

Bạn ngam cứu thêm theo nó xem sao, nha!

(húc xuân vui vẽ!
 

File đính kèm

  • GPE.rar
    36.4 KB · Đọc: 23
HYen17 đã viết:
Vì số ô trống liên tiếp ít nhứt của các hàng đều là 1, nên mình nghĩ không cần fải ghi lại làm chi đó nha!

Nếu bạn ghi là: "Tìm cột đầu tiên trong hàng mà có số ô rỗng liên tiếp ít nhứt" thì mình sẽ làm khác như file đính kèm dưới đây.

Nhưng dòng 50 trong nớ mình đã sửa lại để chương trình cho thẩy các đáp án 1 cách tổng quát hơn.

Bạn ngam cứu thêm theo nó xem sao, nha!

(húc xuân vui vẽ!
Nhấp chuột vào đây để mở rộng...
Vâng cảm ơn bạn!
Mình đã test file bạn gửi thì:
+ kết quả 1; 3 và 6 rất đúng ý tưởng ạ, rất tuyệt vời!
+ Còn kết quả 2 thì bạn làm hơi khác một chút, kết quả bạn tìm ra lại là chỉ vị trí cột có ô trống cần tìm?(Hì, mình lại cần kết quả là chỉ số ô trống liên tiếp nhỏ nhất có trong hàng bắt đầu đếm từ cột B - Giống như cách làm của kết quả 1; 3 và 6 bạn làm!)
+ Còn kết quả 4: tìm số ô có dữ liệu liên tiếp nhiều nhất có trong hàng bắt đầu đếm từ cột B thì code mình thấy không chạy?
- Cảm ơn bạn rất nhiều đã giúp đỡ mình! Mong bạn xem giúp mình với nhé! Chúc bạn năm mới nhiều may mắn! Thân ái! Mong tin bạn! Cảm ơn GPE!
 
Hôm nay ngày cuối tháng chạp:

PHP: 
Option Explicit
Sub MaxValueRangeInRow()
 Dim eCol As Byte, eRw As Long, jJ As Long, Max_ As Byte, SoOvl As Byte
 Dim RCuoi As Range, vlRg As Range, sRng As Range, RDau As Range
 Dim Timer_ As Double
  Sheets("S1").Select:                          Timer_ = Timer
 Set RCuoi = [B2].CurrentRegion
 eCol = RCuoi.Columns.Count + 1:                eRw = RCuoi.Rows.Count
 
 Columns("B:B").Insert Shift:=xlToRight
 For jJ = 4 To eRw
    Max_ = 0
    If Cells(jJ, "C").Value = "" Then
        Set RCuoi = Cells(jJ, "B").End(xlToRight).Offset(, -1)
    Else
        Set RCuoi = Cells(jJ, "B")
    End If
    Do
        If RCuoi.Column > eCol Then
            sRng.Interior.ColorIndex = 37
            Cells(jJ, "GT").Value = Max_
            Set sRng = Nothing:                     Exit Do
        End If
        If RCuoi.Offset(, 2).Value = "" Then
            Set vlRg = RCuoi.Offset(, 1)
        Else
            Set vlRg = Range(RCuoi.Offset(, 1), RCuoi.Offset(, 1).End(xlToRight))
        End If

        SoOvl = vlRg.Count
        If SoOvl > Max_ Then
            Set sRng = vlRg:                Max_ = SoOvl
        End If
        
        If SoOvl = 1 Then
            Set RCuoi = vlRg.End(xlToRight).Offset(, -1)
        Else
            Set RCuoi = RCuoi.Offset(, SoOvl).End(xlToRight).Offset(, -1)
        End If
    Loop
 Next jJ
 
  Columns("B:B").Delete
 [gS1].Value = Timer - Timer_
End Sub
 
SA_DQ đã viết:
PHP: 
Option Explicit
Sub MaxValueRangeInRow()
Dim eCol As Byte, eRw As Long, jJ As Long, Max_ As Byte, SoOvl As Byte
Dim RCuoi As Range, vlRg As Range, sRng As Range, RDau As Range
Dim Timer_ As Double
Sheets("S1").Select: Timer_ = Timer
Set RCuoi = [B2].CurrentRegion
eCol = RCuoi.Columns.Count + 1: eRw = RCuoi.Rows.Count
 
Columns("B:B").Insert Shift:=xlToRight
For jJ = 4 To eRw
Max_ = 0
If Cells(jJ, "C").Value = "" Then
Set RCuoi = Cells(jJ, "B").End(xlToRight).Offset(, -1)
Else
Set RCuoi = Cells(jJ, "B")
End If
Do
If RCuoi.Column > eCol Then
sRng.Interior.ColorIndex = 37
Cells(jJ, "GT").Value = Max_
Set sRng = Nothing: Exit Do
End If
If RCuoi.Offset(, 2).Value = "" Then
Set vlRg = RCuoi.Offset(, 1)
Else
Set vlRg = Range(RCuoi.Offset(, 1), RCuoi.Offset(, 1).End(xlToRight))
End If
 
SoOvl = vlRg.Count
If SoOvl > Max_ Then
Set sRng = vlRg: Max_ = SoOvl
End If
 
If SoOvl = 1 Then
Set RCuoi = vlRg.End(xlToRight).Offset(, -1)
Else
Set RCuoi = RCuoi.Offset(, SoOvl).End(xlToRight).Offset(, -1)
End If
Loop
Next jJ
 
Columns("B:B").Delete
[gS1].Value = Timer - Timer_
End Sub
Nhấp chuột vào đây để mở rộng...
Bác SA_DQ ! Cảm ơn bác nhiều lắm! Bác nhớ code của kết quả 1 không, tác giả chính là của Bác đó!
Chúc bác xuân tân Mão An Khang Thịnh Vượng!
- Bác SA_DQ ơi đúng quá, mình vừa test xong! Hì! Mong bác có thể giúp cho 2 trường hợp cuối cùng được không ạ? Đó là kết quả 2 và kết quả 5! Cảm ơn bác!
 
Lần chỉnh sửa cuối:
6 macro của bạn đây & xin mời

Bạn kiểm tra lại xem sao?!
 

File đính kèm

  • GPE.rar
    37.3 KB · Đọc: 34
Vâng! Cảm ơn bạn HYen 17 nhiều quá! Tết này được đón xuân vui vẻ rồi! Chúc mừng năm mới! Chúc Bạn và gia đình nhiều may mắn! Chúc GPE vui xuân thắng lợi! Thân ái!
- Bạn HYen17 ơi! Mình test và thấy 2 code cuối-kết quả 2 và kết quả 5 không được đúng? Bạn xem giúp mình với nhé!
- Còn 4 kết quả kia thì rất đúng ý ạ! Cảm ơn bạn!

HYen17 đã viết:
Bạn kiểm tra lại xem sao?!
Nhấp chuột vào đây để mở rộng...
Bạn Hyen 17 ơi! Code cho kết quả 2 và 5 vẫn là chỉ ra vị trí thứ tự cột? Bạn có thể sửa lại sao cho kết quả giống như cách tìm các điều kiện kia?
-Ví dụ: ở kết quả 2: tìm số ô trống min trong hàng đếm từ cột B: ở hàng thứ 4 (hàng 1;2) thì số ô trống min trong hàng là 1 thì phần kết quả ghi là kết quả: 1, chứ không phải ghi kết quả là vị trí cột là 4? Ở hàng thứ 5 (hàng 1;3) thì số ô trống min trong hàng là 1 thì phần kết quả 2 ghi là 1 chứ không phải là 9(vị trí của cột)!
- Tương tự như vậy ở kết quả 5 thì cách tìm cũng giống như ở kết quả 2!
Mong bạn giúp đỡ! Thân ái! Chúc bạn và gia đình có những ngày tết vui vẻ!
 
Chỉnh sửa lần cuối bởi điều hành viên:
Bạn sửa lại ở 2 dòng lệnh như dưới đây (& Hắn xỉn rồi!)

PHP: 
Sub MinBlankRangeInRows()
 Dim eCol As Byte, eRw As Long, jJ As Long, Min_ As Byte, SoOR As Byte
 Dim RCuoi As Range, RgR As Range, lRng As Range, RDau As Range
 Dim Timer_ As Double
 On Error GoTo LoiCT
 
 Sheets("S1").Select:                           Timer_ = Timer
 Set RCuoi = [B2].CurrentRegion
 eCol = RCuoi.Columns.Count:                     eRw = RCuoi.Rows.Count
 
 For jJ = 4 To eRw
    Min_ = eCol
    If Cells(jJ, "B").Value = "" Then
        Set RCuoi = Cells(jJ, "a")
    Else
        Set RCuoi = Cells(jJ, "A").End(xlToRight)
    End If
   Do
        Set RDau = RCuoi.End(xlToRight) ' Xac Dinh O Co Tri Tiep theo'
        If RDau.Column > eCol Or RCuoi.Column > eCol Then
            Cells(jJ, "GQ").Value = lRng.Count  '<=|'
            lRng.Interior.ColorIndex = 36:      Set lRng = Nothing
            Min_ = eCol:                        Exit Do
        End If
        
        Set RgR = Range(RCuoi.Offset(, 1), RDau.Offset(, -1)) 'Cac O Rong'
        SoOR = RgR.Count
        If SoOR = 1 Then
            RgR.Interior.ColorIndex = 36
            Cells(jJ, "GQ").Value = 1           '<=|RgR.Column'
5            If Not lRng Is Nothing Then Set lRng = Nothing
            Min_ = eCol:                        Exit Do
        ElseIf SoOR > 1 Then
            If SoOR < Min_ Then
                Min_ = SoOR:                    Set lRng = RgR
            End If
        End If
        
        If RDau.Offset(, 1).Value = "" Then
            Set RCuoi = RDau
        Else
            Set RCuoi = RDau.End(xlToRight)
        End If
   Loop
 Next jJ
 [gq1].Value = Timer - Timer_
 
Err_:                   Exit Sub
LoiCT:
    MsgBox Erl, , Err & ": " & Error
    Resume Err_
End Sub

(húc xuân vui vẻ! --=0 --=0 --=0
 
Còn macro thứ 5 sửa lại như ri:

PHP: 
Sub MinValueRangeInRow()
 Dim eCol As Byte, eRw As Long, jJ As Long, Max_ As Byte, SoOvl As Byte
 Dim RCuoi As Range, vlRg As Range, sRng As Range, RDau As Range
 Dim Timer_ As Double
  Sheets("S1").Select:                          Timer_ = Timer
 Set RCuoi = [B2].CurrentRegion
 eCol = RCuoi.Columns.Count + 1:                eRw = RCuoi.Rows.Count
 
 Columns("B:B").Insert Shift:=xlToRight
 For jJ = 4 To eRw
    Max_ = eCol
    If Cells(jJ, "C").Value = "" Then
        Set RCuoi = Cells(jJ, "B").End(xlToRight).Offset(, -1)
    Else
        Set RCuoi = Cells(jJ, "B")
    End If
    Do
        If RCuoi.Column > eCol Then
            sRng.Interior.ColorIndex = 40
            Cells(jJ, "Gu").Value = sRng.Count           '<=|sRng(1).Column - 1'
            Set sRng = Nothing:                     Exit Do
        End If
        If RCuoi.Offset(, 2).Value = "" Then
            RCuoi.Offset(, 1).Interior.ColorIndex = 40
            Cells(jJ, "Gu").Value = 1   '<=|RCuoi.Offset(, 1).Column - 1'
            Set sRng = Nothing:                     Exit Do
        Else
            Set vlRg = Range(RCuoi.Offset(, 1), RCuoi.Offset(, 1).End(xlToRight))
        End If

        SoOvl = vlRg.Count
        If SoOvl < Max_ Then
            Set sRng = vlRg:                Max_ = SoOvl
        End If
        Set RCuoi = RCuoi.Offset(, SoOvl).End(xlToRight).Offset(, -1)
    Loop
 Next jJ
 
  Columns("B:B").Delete
 [gT1].Value = Timer - Timer_

End Sub
 
Rảnh rỗi viết cho bạn tham khảo 1 hàm tự tạo

PHP: 
Option Explicit
Function MaxBlanks(Vung As Range)
 Dim eCol As Byte, SoOR As Byte, Max_ As Byte
 Dim Rng0 As Range, Rng9 As Range, lRng As Range
 
 eCol = Vung.Count
 If Vung(1).Value = "" Then
    Set Rng0 = Vung(1).Offset(, -1)
 Else
    Set Rng0 = Vung(1).Offset(, -1).End(xlToRight)
 End If
 Do
    Set Rng9 = Rng0.End(xlToRight)
    If Rng9.Column > eCol Then
        MaxBlanks = Max_ - 1:                 Exit Do
    End If
    SoOR = Range(Rng0, Rng9).Count - 1
    If SoOR > Max_ Then
        Max_ = SoOR:
        Set lRng = Rng0.Offset(, 1).Resize(, SoOR - 1)
      End If
      Set Rng0 = Rng9
 Loop
End Function

Cách dùng: Tại ô [GO4] bạn nhập cú fáp sau: =MaxBlanks(B4:GN4)

 
ChanhTQ@ đã viết:
PHP: 
Option Explicit
Function MaxBlanks(Vung As Range)
Dim eCol As Byte, SoOR As Byte, Max_ As Byte
Dim Rng0 As Range, Rng9 As Range, lRng As Range

eCol = Vung.Count
If Vung(1).Value = "" Then
Set Rng0 = Vung(1).Offset(, -1)
Else
Set Rng0 = Vung(1).Offset(, -1).End(xlToRight)
End If
Do
Set Rng9 = Rng0.End(xlToRight)
If Rng9.Column > eCol Then
MaxBlanks = Max_ - 1: Exit Do
End If
SoOR = Range(Rng0, Rng9).Count - 1
If SoOR > Max_ Then
Max_ = SoOR:
Set lRng = Rng0.Offset(, 1).Resize(, SoOR - 1)
End If
Set Rng0 = Rng9
Loop
End Function

Cách dùng: Tại ô [GO4] bạn nhập cú fáp sau: =MaxBlanks(B4:GN4)
Nhấp chuột vào đây để mở rộng...

Vâng! Cách này cũng hay quá! Cảm ơn bác nhiều!
 
Để xử topic dưới đây, chắc cần UDF sau, ngỏ hầu rút tiến trình!

http://www.giaiphapexcel.com/forum/showthread.php?45292-Ghép-dòng
PHP: 
Option Explicit
Function MaxValues(Vung As Range, Optional CucDai As Byte)
 'Nho Them 1 Cot Trong Vo Dau CSDL!'
 Dim eCol As Byte, Max_ As Byte, SoOvl As Byte
 Dim RCuoi As Range, vlRg As Range, sRng As Range, RDau As Range
 
 eCol = Vung.Columns.Count
 If CucDai = 0 Then CucDai = eCol
 If Vung(1).Value = "" Then
    Set RCuoi = Vung(0).End(xlToRight).Offset(, -1)
 Else
    Set RCuoi = Vung(0)
 End If
 Do
    If RCuoi.Column > eCol Then
        MaxValues = Max_:           Exit Do
    End If
    If RCuoi.Offset(, 2).Value = "" Then
        Set vlRg = RCuoi.Offset(, 1)
    Else
        Set vlRg = Range(RCuoi.Offset(, 1), RCuoi.Offset(, 1).End(xlToRight))
    End If
    SoOvl = vlRg.Count
    If SoOvl > Max_ Then
        Set sRng = vlRg:                Max_ = SoOvl
    End If
    If Max_ > CucDai Then
        MaxValues = Max_:               Exit Function
    End If
    If SoOvl = 1 Then
        Set RCuoi = vlRg.End(xlToRight).Offset(, -1)
    Else
        Set RCuoi = RCuoi.Offset(, SoOvl).End(xlToRight).Offset(, -1)
    End If
 Loop
End Function
 
Lần chỉnh sửa cuối:
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

P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
2
Đọc
136
phantu93
P
V
công thức của nó là gì ạ. mong mọi người giúp
Trả lời
1
Đọc
28
CHAOQUAY
C
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
13
Đọc
273
ongke0711
ongke0711
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
25
Đọc
577
tle2003
T
vuongnlks
Lấy dữ liệu 1 cột cụ thể theo ngày từ nhiều file CSV ứng với mã tương ứng trong cột MA CO PHIEU
Trả lời
1
Đọc
97
BuiQuangThuan
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom