Lọc dữ liệu

Liên hệ QC
H

hcl_pt

Thành viên thường trực
Tham gia
21/10/10
Bài viết
208
Được thích
11
Mình xin hỏi GPE, làm sao lọc ra được các hàng dữ liệu trong excel 2003 thoả mãn điều kiện: CSDL ở sheet1: nếu hàng dữ liệu nào đó chỉ có tối đa 2 ô trống liên tiếp thì chép sang sheet2, nếu có tối đa 3 ô trống liên tiếp thì chép sang sheet3, nếu có tối đa 4 ô trống liên tiếp thì chép sang sheet4 và nếu tối đa có 5 ô trống liên tiếp thì chép sang sheet5! Mình xin cảm ơn!
 

File đính kèm

  • LỌC_DỮ_LIỆU .rar
    825.4 KB · Đọc: 130
Lần chỉnh sửa cuối:
hcl_pt đã viết:
Mình xin hỏi GPE, làm sao lọc ra được các hàng dữ liệu trong excel 2003 thoả mãn điều kiện: CSDL ở sheet1: nếu hàng dữ liệu nào đó chỉ có tối đa 2 ô trống liên tiếp thì chép sang sheet2, nếu có tối đa 3 ô trống liên tiếp thì chép sang sheet3, nếu có tối đa 4 ô trống liên tiếp thì chép sang sheet4 và nếu tối đa có 5 ô trống liên tiếp thì chép sang sheet5! Mình xin cảm ơn!
Nhấp chuột vào đây để mở rộng...

Chân thành nhờ GPE giúp đỡ mình với! Các bạn xem và giúp đỡ mình được không? Mình xin cảm ơn nhiều!
 
hcl_pt đã viết:
Mình xin hỏi GPE, làm sao lọc ra được các hàng dữ liệu trong excel 2003 thoả mãn điều kiện: CSDL ở sheet1: nếu hàng dữ liệu nào đó chỉ có tối đa 2 ô trống liên tiếp thì chép sang sheet2, nếu có tối đa 3 ô trống liên tiếp thì chép sang sheet3, nếu có tối đa 4 ô trống liên tiếp thì chép sang sheet4 và nếu tối đa có 5 ô trống liên tiếp thì chép sang sheet5! Mình xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Nếu có > 5 ô trống liên tiếp thì có chép không và chép sang sh nào. Số ô trống liên tiếp max của data là bao nhiêu. Hay là phải đếm trước.
Mấy bài dạng này ứng dụng trong lĩnh vực gì vậy. Bài này cũng tương tự data như bài của bạn Sep...
 
ThuNghi đã viết:
Nếu có > 5 ô trống liên tiếp thì có chép không và chép sang sh nào. Số ô trống liên tiếp max của data là bao nhiêu. Hay là phải đếm trước.
Mấy bài dạng này ứng dụng trong lĩnh vực gì vậy. Bài này cũng tương tự data như bài của bạn Sep...
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn ThuNghi! Dự định của mình muốn phát triển lên 10 sheet! Nếu bạn giúp được thì hay quá! Mình trình bày lại điều kiện: từ dữ liệu ở sheet1, nếu hàng dữ liệu nào có: ô trống liên tiếp max là 2 thì chép sang sheet2, ô trống liên tiếp max là 3 thì chép sang sheet3, ô trống liên tiếp max là 4 thì chép sang sheet4,.v.v.., ô trống liên tiếp max là 10 thì chép sang sheet10, còn lại là bỏ qua! Chúc bạn nhiều may mắn!
 
hcl_pt đã viết:
Cảm ơn bạn ThuNghi! Dự định của mình muốn phát triển lên 10 sheet! Nếu bạn giúp được thì hay quá! Mình trình bày lại điều kiện: từ dữ liệu ở sheet1, nếu hàng dữ liệu nào có: ô trống liên tiếp max là 2 thì chép sang sheet2, ô trống liên tiếp max là 3 thì chép sang sheet3, ô trống liên tiếp max là 4 thì chép sang sheet4,.v.v.., ô trống liên tiếp max là 10 thì chép sang sheet10, còn lại là bỏ qua! Chúc bạn nhiều may mắn!
Nhấp chuột vào đây để mở rộng...
Làm thử với eNull là 5.
Bạn tạo thêm 4 sh có tên là 2, 3,4 ,5 và chạy code sau.
PHP: 
Option Explicit
Dim MyStr As String, sStr As String, shName As String
Const endR = 2000, endC = 237, eNull = 5
Dim i As Long, j As Long, k As Long, s As Long, n As Long, nR As Long, iDong As Long
Dim ArrData(), Arr(), ArrKQ(), ArrS()
Sub TrichLoc()
With Application
  .ScreenUpdating = False
End With
With Sheets("Sheet1")
  ArrData = .Range(.Cells(4, 2), .Cells(endR, endC)).Value
End With
ReDim Arr(1 To UBound(ArrData, 1))
For i = 1 To UBound(ArrData, 1)
  MyStr = "x"
  For j = 1 To UBound(ArrData, 2)
    If Len(ArrData(i, j)) > 0 Then
      MyStr = MyStr & "x"
    Else
      MyStr = MyStr & Space(1)
    End If
  Next j
  Arr(i) = MyStr
Next i
Erase ArrData()
ReDim ArrKQ(1 To UBound(Arr), 1 To 2)
s = 0
For i = 1 To UBound(Arr)
  For k = eNull To 2 Step -1
    sStr = "x" & Space(k) & "x"
    If InStr(1, Arr(i), sStr) > 0 Then
      s = s + 1
      ArrKQ(s, 1) = i
      ArrKQ(s, 2) = k
      Exit For
    End If
  Next k
Next i
With Sheets("Sheet1")
  ArrData = .Range(.Cells(4, 1), .Cells(endR, endC)).Value
End With
For j = 2 To eNull
  shName = j
  With Sheets(shName)
   .Range(.Cells(4, 1), .Cells(endR, endC)).ClearContents
  End With
  n = 0
  ReDim ArrS(1 To s, 1 To endC)
  For i = 1 To s
    iDong = ArrKQ(i, 1)
    If ArrKQ(i, 2) = j Then
      n = n + 1
      For k = 1 To endC
        ArrS(n, k) = ArrData(iDong, k)
      Next k
    End If
  Next i
  If n > 0 Then
    With Sheets(shName)
      .Range("A4").Resize(n, endC) = ArrS
    End With
  End If
Next j
Erase ArrData(), Arr(), ArrKQ(), ArrS
With Application
  .ScreenUpdating = True
End With
End Sub
Chạy OK thì rút gọn lại sau.
Bạn nhớ thay code trên nhé, do file lớn nên kg up lại.
Có hể thay eNull =10 và nhớ thêm sh cho phù hợp.
 

File đính kèm

  • LocDuLieu01.rar
    957.5 KB · Đọc: 76
Lần chỉnh sửa cuối:
Max là 21 ô trống đó! & đây là cách chân fương nhứt; ThuNghi tìm cách rút gọn nha

PHP: 
Option Explicit
Sub FilterRows()
 Dim eCol As Byte, Ww As Byte, eRw As Long, Jj As Long, Max_ As Byte
 Dim Rng As Range, RgR As Range
 
 Sheets("S0").Select
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                   eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   For Ww = 2 To eCol
      If Cells(Jj, Ww).Value = "" Then
         If RgR Is Nothing Then
            Set RgR = Cells(Jj, Ww)
         Else
            Set RgR = Union(RgR, Cells(Jj, Ww))
         End If
      Else
         If Not RgR Is Nothing Then
            If RgR.Count > Max_ Then
               Max_ = RgR.Count:             Set Rng = RgR
            End If
            Set RgR = Nothing
         End If
      End If
   Next Ww
   Cells(Jj, eCol + 2).Value = Max_:         Max_ = 0
   Set RgR = Nothing:                        Rng.Interior.ColorIndex = 38
   Set Rng = Nothing
 Next Jj
End Sub
 

File đính kèm

  • GPEf.rar
    851.2 KB · Đọc: 80
Để đi đến đích thì có nhiều con đường để đi! Thật tuyệt! Cảm ơn các bạn! Đúng là biển học vô bờ!
 
SA_DQ đã viết:
PHP: 
Option Explicit
Sub FilterRows()
 Dim eCol As Byte, Ww As Byte, eRw As Long, Jj As Long, Max_ As Byte
 Dim Rng As Range, RgR As Range
 
 Sheets("S0").Select
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                   eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   For Ww = 2 To eCol
      If Cells(Jj, Ww).Value = "" Then
         If RgR Is Nothing Then
            Set RgR = Cells(Jj, Ww)
         Else
            Set RgR = Union(RgR, Cells(Jj, Ww))
         End If
      Else
         If Not RgR Is Nothing Then
            If RgR.Count > Max_ Then
               Max_ = RgR.Count:             Set Rng = RgR
            End If
            Set RgR = Nothing
         End If
      End If
   Next Ww
   Cells(Jj, eCol + 2).Value = Max_:         Max_ = 0
   Set RgR = Nothing:                        Rng.Interior.ColorIndex = 38
   Set Rng = Nothing
 Next Jj
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn Bác nhiều, em đang nghiên cứu xem có cách nào tìm số ô rỗng liên tiếp lớn nhất trong 1 dòng từ cột 1 đến cột 256.
Theo Bác dùng find hay dùng
With .Range("A1:A256")
.SpecialCells(xlCellTypeBlanks).Select
End With
Nhấp chuột vào đây để mở rộng...
Có được không và có nhanh.
Cám ơn Bác. Em chưa nghĩ ra ngoài for i.
 
Chờ hoài, rồi cũng thấy Tuấn hưởng ứng, khà, khà, . . .

Dưới đây là mình dùng fương thức End(xlToRigh) & thời lượng giảm 5 lần so với For . . . Next


PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng0 As Range, lRng As Range
 Dim Timer_ As Double
 
 Sheets("S1").Select:                        Timer_ = Timer
 Set Rng0 = [B2].CurrentRegion
 eCol = Rng0.Columns.Count:                   eRw = Rng0.Rows.Count
 For Jj = 4 To eRw
   
   If Cells(Jj, "B").Value = "" Then
      Set Rng0 = Cells(Jj, "a")
   Else
      Set Rng0 = Cells(Jj, "A").End(xlToRight)
   End If
   Do
      Set RgR = Rng0.End(xlToRight)
      If RgR.Column > eCol Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 39:
         Cells(Jj, eCol + 2).Value = Max_ - 1:       Max_ = 0
         Set lRng = Nothing:                          Exit Do
      End If
      SoOR = Range(Rng0, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR:               Set lRng = Rng0.Offset(, 1).Resize(, SoOR - 1)
      End If
      Set Rng0 = RgR
   Loop
 Next Jj
 [iD1].Value = Timer - Timer_
End Sub
 
SA_DQ đã viết:
Dưới đây là mình dùng fương thức End(xlToRigh) & thời lượng giảm 5 lần so với For . . . Next


PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng0 As Range, lRng As Range
 Dim Timer_ As Double
 
 Sheets("S1").Select:                        Timer_ = Timer
 Set Rng0 = [B2].CurrentRegion
 eCol = Rng0.Columns.Count:                   eRw = Rng0.Rows.Count
 For Jj = 4 To eRw
   
   If Cells(Jj, "B").Value = "" Then
      Set Rng0 = Cells(Jj, "a")
   Else
      Set Rng0 = Cells(Jj, "A").End(xlToRight)
   End If
   Do
      Set RgR = Rng0.End(xlToRight)
      If RgR.Column > eCol Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 39:
         Cells(Jj, eCol + 2).Value = Max_ - 1:       Max_ = 0
         Set lRng = Nothing:                          Exit Do
      End If
      SoOR = Range(Rng0, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR:               Set lRng = Rng0.Offset(, 1).Resize(, SoOR - 1)
      End If
      Set Rng0 = RgR
   Loop
 Next Jj
 [iD1].Value = Timer - Timer_
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn Bác nhiều.
Em thêm 1 điều kiện đếm và dùng Array giảm thêm 1/2 thời gian.
PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, Max_ As Byte, SoOR As Byte, maxC As Long
 Dim RgR As Range, Rng As Range, lRng As Range, myRng As Range
 Dim Timer_ As Double, Arr()
 Dim WF As WorksheetFunction: Set WF = WorksheetFunction
  Sheets("S0").Select:                        Timer_ = Timer
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                   eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   If Cells(Jj, "B").Value = "" Then
      Set Rng = Cells(Jj, "a")
   Else
      Set Rng = Cells(Jj, "A").End(xlToRight)
   End If
   Set myRng = Range(Cells(Jj, 2), Cells(Jj, eCol))
   maxC = WF.CountA(myRng)
   Do
      Set RgR = Rng.End(xlToRight)
      If RgR.Column > eCol - maxC Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 39:
          ReDim Preserve Arr(1 To Jj - 3)
          Arr(Jj - 3) = Max_ - 1
          Max_ = 0
         Set lRng = Nothing
         Exit Do
      End If
      SoOR = Range(Rng, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR
         Set lRng = Rng.Offset(, 1).Resize(, SoOR - 1)
      End If
      Set Rng = RgR
   Loop
 Next Jj
 [iF4].Resize(Jj - 3) = WF.Transpose(Arr)
 Set myRng = Nothing: Set WF = Nothing
 Erase Arr
 [iF1].Value = Timer - Timer_
End Sub
 
Cả ba fương án còn đang sai so với số thực

Tệ nhứt là 2 fương án sau với fương thức End(xlToRight) lại chọn cả các ô không rỗng để tô màu nữa;

Còn tốn thời gian với việc này!?! --=0 --=0 ;;;;;;;;;;; ;;;;;;;;;;;
 
Nói về tốc độ thì các bác đã tranh nhanh kịch liệt rồi, em không dám thi tiếp, chỉ xin đưa lên 1 giải pháp khác, tuy chậm hơn chút nhưng code gọn hơn:

PHP: 
Function MaxBlk(sRng As Range) As Long
  Dim aRng As Range, iM As Long
  On Error Resume Next
  For Each aRng In sRng.SpecialCells(4).Areas
    If iM < aRng.Count Then iM = aRng.Count
  Next
  MaxBlk = iM
End Function
PHP: 
Sub Main()
  Dim i As Long, j As Long, TG As Double, rRng As Range
  TG = Timer
  Application.ScreenUpdating = False
  With Sheet1.Range("A4:IB2000")
    For i = 1 To .Rows.Count
      j = MaxBlk(.Rows(i))
      If j > 0 And j <= 10 Then
        Set rRng = .Rows(i)
        With Sheets("M" & j)
          .[A1] = .[A1] + 1
          .Cells(.[A1] + 1, 1).Resize(, rRng.Columns.Count).Value = rRng.Value
        End With
      End If
    Next
  End With
  Application.ScreenUpdating = True
  MsgBox Timer - TG
End Sub
Các tên sheet M1, M2,... , M10 đã được đặt trước đó
 
ThuNghi đã viết:
Cám ơn Bác nhiều.
Em thêm 1 điều kiện đếm và dùng Array giảm thêm 1/2 thời gian.
PHP: 
Option Explicit
Sub MaxBlanksInRows()
Dim eCol As Byte, eRw As Long, Jj As Long, Max_ As Byte, SoOR As Byte, maxC As Long
Dim RgR As Range, Rng As Range, lRng As Range, myRng As Range
Dim Timer_ As Double, Arr()
Dim WF As WorksheetFunction: Set WF = WorksheetFunction
Sheets("S0").Select: Timer_ = Timer
Set Rng = [B2].CurrentRegion
eCol = Rng.Columns.Count: eRw = Rng.Rows.Count
For Jj = 4 To eRw
If Cells(Jj, "B").Value = "" Then
Set Rng = Cells(Jj, "a")
Else
Set Rng = Cells(Jj, "A").End(xlToRight)
End If
Set myRng = Range(Cells(Jj, 2), Cells(Jj, eCol))
maxC = WF.CountA(myRng)
Do
Set RgR = Rng.End(xlToRight)
If RgR.Column > eCol - maxC Then
If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 39:
ReDim Preserve Arr(1 To Jj - 3)
Arr(Jj - 3) = Max_ - 1
Max_ = 0
Set lRng = Nothing
Exit Do
End If
SoOR = Range(Rng, RgR).Count - 1
If SoOR > Max_ Then
Max_ = SoOR
Set lRng = Rng.Offset(, 1).Resize(, SoOR - 1)
End If
Set Rng = RgR
Loop
Next Jj
[iF4].Resize(Jj - 3) = WF.Transpose(Arr)
Set myRng = Nothing: Set WF = Nothing
Erase Arr
[iF1].Value = Timer - Timer_
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn các bạn! Các bạn có thể giúp mình sửa lại cách đếm và tô màu số ô trống max theo 1 trong 2 trường hợp sau đây được không:
- Trường hợp 1: Đếm và tô màu số ô trống max theo trường hợp từ phải qua trái. (Các bạn đã giúp mình đếm và tô màu số ô trống max theo trường hợp ngược lại từ trái qua phải rồi. Cảm ơn các bạn!)
- Trường hợp 2: Hàng nào có bao nhiêu khoảng ô trống max thì đều đếm và tô màu cho tất cả các khoảng ô trống max đó. Ví dụ: Hàng có 2 khoảng ô trống max thì đều tô màu cho 2 khoảng ô trống đó!
- Chân Thành Cảm ơn Các Bạn!
 
Rảnh rỗi xào đồ cũ thử chơi

Mình xin GPE lọc từ CSDL ở sheet1 được các hàng dữ liệu thoả mãn điều kiện: : nếu hàng dữ liệu nào đó chỉ có tối đa 3 ô trống liên tiếp thì chép sang sheet3, nếu có tối đa 4 ô trống liên tiếp thì chép sang sheet4 và nếu tối đa có 5 ô trống liên tiếp thì chép sang sheet5!
Nhấp chuột vào đây để mở rộng...

Đây là macro chép chỉ vô 01,0 trang tính 'GPE'; Macro được cải biên dựa theo của NDU bài gần kề trên
 

File đính kèm

  • gpeGiaiThuat.rar
    1.2 MB · Đọc: 32
SA_DQ đã viết:
Dưới đây là mình dùng fương thức End(xlToRigh) & thời lượng giảm 5 lần so với For . . . Next


PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng0 As Range, lRng As Range
 Dim Timer_ As Double
 
 Sheets("S1").Select:                        Timer_ = Timer
 Set Rng0 = [B2].CurrentRegion
 eCol = Rng0.Columns.Count:                   eRw = Rng0.Rows.Count
 For Jj = 4 To eRw
   
   If Cells(Jj, "B").Value = "" Then
      Set Rng0 = Cells(Jj, "a")
   Else
      Set Rng0 = Cells(Jj, "A").End(xlToRight)
   End If
   Do
      Set RgR = Rng0.End(xlToRight)
      If RgR.Column > eCol Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 39:
         Cells(Jj, eCol + 2).Value = Max_ - 1:       Max_ = 0
         Set lRng = Nothing:                          Exit Do
      End If
      SoOR = Range(Rng0, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR:               Set lRng = Rng0.Offset(, 1).Resize(, SoOR - 1)
      End If
      Set Rng0 = RgR
   Loop
 Next Jj
 [iD1].Value = Timer - Timer_
End Sub
Nhấp chuột vào đây để mở rộng...
Chào ngày mới thành công! GPE có thể giúp mình một chút với trường hợp sau của code này được không ạ? Với code này là đếm số ô trống max có trong hàng bắt đầu tính từ cột B tức là cột B không có dữ liệu vẫn đếm
Bây giờ mình muốn sửa lại đôi chút vẫn là đếm số ô trống max có trong hàng nhưng là bắt đầu tính từ ô có dữ liệu đầu tiên ở trong hàng xét từ cột B trở đi (tức là tìm số ô trống max ở trong hàng được chặn ở 2 đầu là 2 ô có dữ liệu xét từ cột B trở đi).Xin chân thành cảm ơn!
!
 
Bạn lấy macro của ThuNghi & sửa lại 1 dòng lệnh như dưới đây & kiểm lại xem sao.

PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, maxC As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng As Range, lRng As Range, myRng As Range
 Dim Timer_ As Double, Arr()
 Dim WF As WorksheetFunction:                       Set WF = WorksheetFunction
 
 Sheets("Sheet1").Select:                          Timer_ = Timer
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                          eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   If Cells(Jj, "B").Value = "" Then
      Set Rng = Cells(Jj, "a")
   Else
      Set Rng = Cells(Jj, "A").End(xlToRight)
   End If
   Set myRng = Range(Cells(Jj, 2), Cells(Jj, eCol))
   maxC = WF.CountA(myRng)
   Do
      Set RgR = Rng.End(xlToRight)
      If RgR.Column > eCol - maxC Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 42
          ReDim Preserve Arr(1 To Jj - 3)
          Arr(Jj - 3) = Max_ - 1
          Max_ = 0
         Set lRng = Nothing
         Exit Do
      End If
      SoOR = Range(Rng, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR
9       If Rng(1).Column > 2 Then _
            Set lRng = Rng.Offset(, 1).Resize(, SoOR - 1)   '**'
      End If
      Set Rng = RgR
   Loop
 Next Jj
 [iF4].Resize(Jj - 3) = WF.Transpose(Arr)
 Set myRng = Nothing: Set WF = Nothing
 Erase Arr
 [iF1].Value = Timer - Timer_
End Sub
 
HYen17 đã viết:
PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, maxC As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng As Range, lRng As Range, myRng As Range
 Dim Timer_ As Double, Arr()
 Dim WF As WorksheetFunction:                       Set WF = WorksheetFunction
 
 Sheets("Sheet1").Select:                          Timer_ = Timer
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                          eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   If Cells(Jj, "B").Value = "" Then
      Set Rng = Cells(Jj, "a")
   Else
      Set Rng = Cells(Jj, "A").End(xlToRight)
   End If
   Set myRng = Range(Cells(Jj, 2), Cells(Jj, eCol))
   maxC = WF.CountA(myRng)
   Do
      Set RgR = Rng.End(xlToRight)
      If RgR.Column > eCol - maxC Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 42
          ReDim Preserve Arr(1 To Jj - 3)
          Arr(Jj - 3) = Max_ - 1
          Max_ = 0
         Set lRng = Nothing
         Exit Do
      End If
      SoOR = Range(Rng, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR
9       If Rng(1).Column > 2 Then _
            Set lRng = Rng.Offset(, 1).Resize(, SoOR - 1)   '**'
      End If
      Set Rng = RgR
   Loop
 Next Jj
 [iF4].Resize(Jj - 3) = WF.Transpose(Arr)
 Set myRng = Nothing: Set WF = Nothing
 Erase Arr
 [iF1].Value = Timer - Timer_
End Sub
Nhấp chuột vào đây để mở rộng...
Vâng! Ý tưởng đúng là như vậy bạn àh! Số ô trống max đã được tô màu nhưng sao phần kết quả lại không xuất ra như phần code của bác SA_DQ ạ? Code của bác SA_DQ rất hay vì dù số liệu bao nhiêu đi nữa thì kết quả luôn xuất ra ở cột cuối! Nếu bạn làm thêm phần xuất ra kết quả theo như của bác SA_DQ để dễ bề kiểm tra thì hay quá! Thân ái!
 
HYen17 đã viết:
PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, maxC As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng As Range, lRng As Range, myRng As Range
 Dim Timer_ As Double, Arr()
 Dim WF As WorksheetFunction:                       Set WF = WorksheetFunction
 
 Sheets("Sheet1").Select:                          Timer_ = Timer
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                          eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   If Cells(Jj, "B").Value = "" Then
      Set Rng = Cells(Jj, "a")
   Else
      Set Rng = Cells(Jj, "A").End(xlToRight)
   End If
   Set myRng = Range(Cells(Jj, 2), Cells(Jj, eCol))
   maxC = WF.CountA(myRng)
   Do
      Set RgR = Rng.End(xlToRight)
      If RgR.Column > eCol - maxC Then
         If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 42
          ReDim Preserve Arr(1 To Jj - 3)
          Arr(Jj - 3) = Max_ - 1
          Max_ = 0
         Set lRng = Nothing
         Exit Do
      End If
      SoOR = Range(Rng, RgR).Count - 1
      If SoOR > Max_ Then
         Max_ = SoOR
9       If Rng(1).Column > 2 Then _
            Set lRng = Rng.Offset(, 1).Resize(, SoOR - 1)   '**'
      End If
      Set Rng = RgR
   Loop
 Next Jj
 [iF4].Resize(Jj - 3) = WF.Transpose(Arr)
 Set myRng = Nothing: Set WF = Nothing
 Erase Arr
 [iF1].Value = Timer - Timer_
End Sub
Nhấp chuột vào đây để mở rộng...
Các bạn có thể giúp mình được không ạ? Với code này thì mình phải làm sao chỉnh sửa để có kết quả dán ở cuối cột dữ liệu như của bác SA_DQ ạ? Mong sự chỉ bảo của các bạn! Thân ái
 
Thật ra code của ThuNghi có đưa số liệu ra cột [IF], hay bạn thử chỉnh lại vầy:

PHP: 
Option Explicit
Sub MaxBlanksInRows()
 Dim eCol As Byte, eRw As Long, Jj As Long, maxC As Long, Max_ As Byte, SoOR As Byte
 Dim RgR As Range, Rng As Range, lRng As Range, myRng As Range
 Dim Timer_ As Double, Arr()
 Dim WF As WorksheetFunction:                       Set WF = WorksheetFunction
 
 Sheets("Sheet1").Select:                          Timer_ = Timer
 Set Rng = [B2].CurrentRegion
 eCol = Rng.Columns.Count:                          eRw = Rng.Rows.Count
 For Jj = 4 To eRw
   If Cells(Jj, "B").Value = "" Then
      Set Rng = Cells(Jj, "a")
   Else
      Set Rng = Cells(Jj, "A").End(xlToRight)
   End If
   Set myRng = Range(Cells(Jj, 2), Cells(Jj, eCol))
   maxC = WF.CountA(myRng)
   Do
      Set RgR = Rng.End(xlToRight)
      If RgR.Column > eCol - maxC Then
1         If Not lRng Is Nothing Then
            lRng.Interior.ColorIndex = 42
3            Cells(Jj, eCol + 3).Value = lRng.Cells.Count
         End If
          ReDim Preserve Arr(1 To Jj - 3)
          Arr(Jj - 3) = Max_ - 1
          Max_ = 0
         Set lRng = Nothing
         Exit Do
      End If
5      If Range(Rng, RgR)(1).Column > 2 Then
            SoOR = Range(Rng, RgR).Count - 1
        Else
            SoOR = 1
7        End If
        
      If SoOR > Max_ Then
         Max_ = SoOR
       If Rng(1).Column > 2 Then _
            Set lRng = Rng.Offset(, 1).Resize(, SoOR - 1)   '**'
      End If
      Set Rng = RgR
   Loop
 Next Jj
9 ' [iF4].Resize(Jj - 3) = WF.Transpose(Arr)'
 Set myRng = Nothing: Set WF = Nothing
 Erase Arr
 Cells(1, eCol + 3).Value = Timer - Timer_           '<=|'
End Sub
 
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

PhanTuHuong
Các địa phương thiệt hại nặng nề do bão lũ 2024
    • Thích
2
Trả lời
23
Đọc
753
SA_DQ
SA_DQ
D
Phân công và sắp xếp lịch trực
Trả lời
9
Đọc
215
dangg
D
T
  • Question
Tính tồn đầu , tồn cuối , nhập trong kỳ , xuất trong kỳ
Trả lời
11
Đọc
242
thierry henry
T
GPE-Trợ Lý
Đà Nẵng - Đăng ký tham dự sinh nhật GIAIPHAPEXECL lần thứ 18 ngày 05/10/2024
    • Thích
    • Yêu thích
Trả lời
9
Đọc
178
Maika8008
Maika8008
U
VLOOKUP nhiều cột
    • Chấp nhận
Trả lời
5
Đọc
180
DeTong
D
GPE-Trợ Lý
TP.HCM - Đăng ký tham dự sinh nhật GIAIPHAPEXCEL lần thứ 18 ngày 06/10/2024
    • Thích
2
Trả lời
21
Đọc
967
ptm0412
ptm0412
T
Hàm Sumifs nhiều điều kiện bị lỗi value hoặc trả về 0
Trả lời
14
Đọc
215
ptm0412
ptm0412
ongke0711
  • Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
11 12 13
Trả lời
255
Đọc
23K
ngochienbmt
N
C
Công thức gộp 2 cột thành 1 (dữ liệu gộp so le)
Trả lời
10
Đọc
947
nguyenhuyen0805
N
H
  • Question
Lập trình số liệu Nhập-Xuất-Tồn
2
Trả lời
23
Đọc
400
HUONGHCKT
H
A
  • Question
Nhờ tìm lỗi code không delete các dòng theo điều kiện
    • Cười
2
Trả lời
29
Đọc
445
SA_DQ
SA_DQ
Kiều Mạnh
Lấy dữ liệu cổ phiếu từ Website Cafef.vn về Excel
    • Thích
3 4 5
Trả lời
81
Đọc
3K
Kiều Mạnh
Kiều Mạnh
C
Quản lý tồn kho ván gỗ
Trả lời
10
Đọc
2K
tamthanhpytn
T
H
Xin giúp đỡ công thức excel để tính nâng lương định kỳ
Trả lời
17
Đọc
8K
ngoclam081077
N
K
Lọc dữ liệu gần nhất trong cột
Trả lời
4
Đọc
110
Hoàng Tuấn 868
H
Q
  • Question
Nhờ các bác hướng dẫn hàm filter dùm.
Trả lời
7
Đọc
196
quen_tat_ca
Q
anhnghi07
  • Question
Excel có chứa chương trình VBA: Mỗi khi đã tắt vẫn hiện lại ô thông báo yêu cầu điền mật khẩu!
Trả lời
10
Đọc
178
anhnghi07
anhnghi07
Dai Minh Kim
Excel báo lỗi khi Open
Trả lời
1
Đọc
117
PhanTuHuong
PhanTuHuong
A
  • Question
Mong giúp đỡ tối ưu hoá vòng lặp code tự động điền ngày
    • Cười
Trả lời
4
Đọc
141
Hoàng Tuấn 868
H
Linh Mia
Tìm kiếm dữ liệu dựa vào nhiều điều kiện (điều kiện thuộc khoảng, điều kiện cố định)
    • Chấp nhận
Trả lời
6
Đọc
259
Linh Mia
Linh Mia
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

Back
Top Bottom