Cần sự giúp đỡ để lọc dữ liệu!!!

Liên hệ QC
S

sontvxd10

Thành viên mới
Tham gia
2/9/07
Bài viết
16
Được thích
2
Chào tất cả các bạn trong 4f. Mình mới tập tành sử dụng VBA nên rất cần sự chỉ giáo của các bạn.
Cụ thể là yêu cầu của mình như sau:


Mình muốn đánh dấu (*) vào cột K ở những hàng có giá trị lớn nhất, nhỏ nhất và trung bình ở cột C cụ thể ở trong hình này là:
Với B1 là các giá trị: 0.11, 1.8 và 3.49
Với B10 là: 0.11, 0.9 và 1.8.
Mình cũng đã thư làm 1 đoạn code để điều khiển cái Button như sau:

Private Sub CommandButton1_Click()

Dim i, j, n As Integer
Dim max, min, tb As Double
n = 4
Do While Cells(n, "B") <> ""
n = n + 1
Loop
n = n - 1
i = 4
j = 4
Cells(j, "K") = "*"
'danh dau * cac gia tri can thiet
For i = j To n
If Cells(i, "B") = Cells(i + 1, "B") Then
If Cells(j, "D") <= Cells(i + 1, "D") Then
Cells(j, "K") = "*"
min = Cells(j, "D")
End If
If Cells(j, "D") >= Cells(i + 1, "D") Then
Cells(j, "K") = "*"
max = Cells(j, "D")
End If
tb = max + min
If Cells(j, "D") = tb Then
Cells(j, "K") = "*"
End If
Else
j = i + 1
Cells(j, "K") = "*"
End If
Next i
End Sub

Nhưng khi chạy nó chỉ đánh dấu (*) tùm lum.**~**
Rất mong các bạn cho ý kiến. Cảm ơn nhiều!!

 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Cảm ơn bác đã bỏ chút thời gian quý báu để góp ý cho em. Code của bác chạy tốt lắm. Nhưng những hàm bác dùng thì lạ quá. Em mới gặp lần đầu. Để em cố hiểu xem ý nghĩa của nó xem. Tiện đây em cũng muốn hỏi thêm bác là. Với những khoảng mà nó có đến 4 giá trị TB mà em chỉ muốn lấy 2 giá trị ứng với 2 trị max và min của cột "I". Em có làm 1 đoạn Code dựa trên Code của bác concogia.
Mã: 
Private Sub CommandButton1_Click()
Rows("4:10000").Delete
Sheets("Du lieu goc").Range("A2:J10000").Copy
Sheets("Du lieu loc").Range("A4").Select
ActiveSheet.Paste
Dim Vung As Range, Wf, iMax, iMax2 As Double, iMin, iMin2 As Double, iMid As Double, VgDem, VgDem2 As Range, i As Long, Bd, Bd2 As Long, a As Long
Set Wf = Application.WorksheetFunction:  Set Vung = Range([a4], [a50000].End(xlUp))
    For i = 1 To Vung.Rows.Count
        If Vung(i) = Vung(i + 1) Then
               Bd = Wf.Match(Vung(i), Vung, 0) + 3
            Set VgDem = Cells(Bd, 1).Resize(Wf.CountIf(Vung, Vung(i))).Offset(, 2)
            iMax = Wf.max(VgDem): iMin = Wf.min(VgDem): iMid = Wf.Round((iMax + iMin) / 2, 5)
            Bd2 = Wf.Match(iMid, VgDem, 0) + 3
            Set VgDem2 = Cells(Bd2, 3).Resize(Wf.CountIf(VgDem, iMid)).Offset(, 6)
            iMax2 = Wf.max(VgDem2): iMin2 = Wf.min(VgDem2)
            If Vung(i).Offset(, 2) = iMid And Vung(i).Offset(, 8) = iMax2 Then Vung(i).Offset(, 10) = "*"
            If Vung(i).Offset(, 2) = iMid And Vung(i).Offset(, 8) = iMin2 Then Vung(i).Offset(, 10) = "*"
                If Vung(i).Offset(, 2) = iMax Or Vung(i).Offset(0, 2) = iMin Then Vung(i).Offset(, 10) = "*"
                a = a + 1
             Else
                    If Vung(i) = Vung(i - 1) And Vung(i) <> Vung(i + 1) Then Vung(i).Offset(, 10) = "*"
                     a = a + 1
        End If
Next
i = 4
    Do While Cells(i, "A") <> ""
        If Cells(i, "K") <> "*" Then
            Rows(i).Delete
        Else
            i = i + 1
        End If
    Loop
    Range("K:K").ClearContents
End Sub
Em cho chạy nhưng chỉ chạy đc trong 1 khoảng của cột "A" nhảy sang khoảng giá trị khác khác là nó báo lỗi liền. Mong ý kiến của các bác.
 
Upvote 0
Em hiểu nó sai ở đâu rồi. Là câu này:
Bd2 = Wf.Match(iMid, VgDem, 0) + 3
VgDem nó nhảy theo từng đoạn nên gias trị màm match đưa ra chỉ đúng với đoạn đầu là "B1" phải sửa lại thành
Bd2 = Wf.Match(iMid, VgDem, 0) + Bd - 1
Nhưng với đoạn 2 thì trị iMid lại không có trong đoạn VgDem nên hàm match bị lỗi. Bác nào có thể chỉ cho em cách khi gặp lỗi này thì cho nó nhảy qua nhận nhận trị max và min thôi không nhận trị TB nữa. Max và min đây là iMax và iMin ứng với cột "C"
 
Upvote 0
sontvxd10 đã viết:
Em hiểu nó sai ở đâu rồi. Là câu này:
Bd2 = Wf.Match(iMid, VgDem, 0) + 3
VgDem nó nhảy theo từng đoạn nên gias trị màm match đưa ra chỉ đúng với đoạn đầu là "B1" phải sửa lại thành
Bd2 = Wf.Match(iMid, VgDem, 0) + Bd - 1
Nhưng với đoạn 2 thì trị iMid lại không có trong đoạn VgDem nên hàm match bị lỗi. Bác nào có thể chỉ cho em cách khi gặp lỗi này thì cho nó nhảy qua nhận nhận trị max và min thôi không nhận trị TB nữa. Max và min đây là iMax và iMin ứng với cột "C"
Nhấp chuột vào đây để mở rộng...
Dùng match trong câu
PHP: 
Bd2 = Wf.Match(iMid, VgDem, 0) + Bd - 1
=> dòng tìm thấy iMid
Nhưng nếu iMid không liên tục thì
PHP: 
Set VgDem2 = Cells(Bd2, 3).Resize(Wf.CountIf(VgDem, iMid)).Offset(, 6)
sẽ không được.
Nếu làm theo match và countif thì nên làm như sau có vẻ dễ hơn. Nên thêm biến solan=countif... cho dễ hình dung.
1/ Lấy danh mục duy nhất Beam (vungduynhat)
2/ Duyệt qua vungduynhat
- Dòng đầu (match)
- Solan (countif)
- Set VungDem
- Tính max, min, TB
3/ Duyệt qua VungDem, if VungDem(i) = iMid => xét min, max M3.
4/ Duyệt qua lại VungDem nếu M3=max or M3=min thì đánh dấu.
Phức tạp quá.
Bạn dùng thử code sau xem có OK không. Tôi làm theo hướng khác.
PHP: 
Option Explicit
Dim Dic As Object, sTmp As String
Dim endR As Long, i As Long, s As Long, k As Long
Dim Arr01, Arr02, Arr03, Arr, ArrKQ
Sub Danhdau()
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr01 = .Range("A2:A" & endR) 'Beam
  Arr02 = .Range("C2:C" & endR) 'Loc
  Arr03 = .Range("I2:I" & endR) 'M3
End With
ReDim Arr(1 To endR - 1, 1 To 6)
s = 0
For i = 1 To endR - 1
  sTmp = Arr01(i, 1)
  If Not Dic.Exists(sTmp) Then
    s = s + 1
    Dic.Add sTmp, s
    Arr(s, 1) = sTmp
  End If
  'Tao ra Arr ghi Min, Max, TB
  k = Dic.Item(sTmp)
  If Arr(k, 2) = "" Or Arr(k, 2) > Arr02(i, 1) Then Arr(k, 2) = Arr02(i, 1) 'min
  If Arr(k, 3) < Arr02(i, 1) Then Arr(k, 3) = Arr02(i, 1) 'max
  Arr(k, 4) = (Arr(k, 2) + Arr(k, 3)) / 2 'TB
Next i
'Duyet them 1 lan de lay Arr02=TB va Arr03 =max hay min
For i = 1 To UBound(Arr03)
  sTmp = Arr01(i, 1)
  If Dic.Exists(sTmp) Then
    k = Dic.Item(sTmp)
  End If
  If Arr02(i, 1) = Val(Arr(k, 4)) Then
    If Arr(k, 5) = "" Or Arr(k, 5) > Arr03(i, 1) Then Arr(k, 5) = Arr03(i, 1) 'min
    If Arr(k, 6) < Arr03(i, 1) Then Arr(k, 6) = Arr03(i, 1) 'max
  End If
Next i
'''Lay nhung dong thoa'
ReDim ArrKQ(1 To UBound(Arr02), 1 To 1)
For i = 1 To UBound(Arr02)
  sTmp = Arr01(i, 1)
  If Dic.Exists(sTmp) Then
    k = Dic.Item(sTmp)
    Select Case Arr02(i, 1)
      Case Val(Arr(k, 2))
        ArrKQ(i, 1) = "Min"
      Case Val(Arr(k, 3))
        ArrKQ(i, 1) = "Max"
      Case Val(Arr(k, 4))
        Select Case Arr03(i, 1)
          Case Val(Arr(k, 5))
            ArrKQ(i, 1) = "minTB"
          Case Val(Arr(k, 6))
            ArrKQ(i, 1) = "maxTB"
        End Select
      End Select
  End If
Next i
Sheets("Data").Select
With Range("K2").Resize(UBound(Arr02), 1)
  .ClearContents
  .Value = ArrKQ
End With
Erase Arr01, Arr02, Arr03, Arr, ArrKQ: Set Dic = Nothing
End Sub
 

File đính kèm

  • TestTBMM.rar
    59 KB · Đọc: 27
Upvote 0
Code của bác OK rồi. Tiếc là em vẫn chưa dịch đc hết. Cái đối tượng "Object" này em ẫn chưa nắm đc. Để em viết lại theo hướng mà bác hướng dẫn xem sao. Có gì mong bác chỉ giáo thêm. Hy vọng 1 ngày nào đó đc giao lưu với bác. Em người xứ Quảng chắc khó mà gặp đc. Chúc bác và gia đình luôn mạnh khỏe.
 
Upvote 0
Ok rồi bác ơi. Theo sự chỉ dẫn của bác em chỉnh lại đc rồi.
Mã: 
Sub Danhdau()
[COLOR=#000000][COLOR=#0000BB][/COLOR][/COLOR]Dim Vung As Range, Wf, iMax, iMax2 As Double, iMin, iMin2 As Double, iMid As Double, VgDem, VgDem2 As Range, i As Long, Bd, Bd2 As Long, a, b As Long
Set Wf = Application.WorksheetFunction:  Set Vung = Range([a4], [a50000].End(xlUp))
b = 0
    For i = 1 To Vung.Rows.Count
        If Vung(i) = Vung(i + 1) Then
            Bd = Wf.Match(Vung(i), Vung, 0) + 3
            Set VgDem = Cells(Bd, 1).Resize(Wf.CountIf(Vung, Vung(i))).Offset(, 2)
            iMax = Wf.max(VgDem): iMin = Wf.min(VgDem): iMid = Wf.Round((iMax + iMin) / 2, 3)
            If Vung(i).Offset(, 2) = iMid Then
                Bd2 = Wf.Match(iMid, VgDem, 0) + Bd - 1
                Set VgDem2 = Cells(Bd2, 3).Resize(Wf.CountIf(VgDem, iMid)).Offset(, 6)
                iMax2 = Wf.max(VgDem2): iMin2 = Wf.min(VgDem2)
                    If Vung(i).Offset(, 2) = iMid And Vung(i).Offset(, 8) = iMax2 Then Vung(i).Offset(, 10) = "*"
                    If Vung(i).Offset(, 2) = iMid And Vung(i).Offset(, 8) = iMin2 Then Vung(i).Offset(, 10) = "*"
                Else
                    If Vung(i).Offset(, 2) = iMax Or Vung(i).Offset(0, 2) = iMin Then Vung(i).Offset(, 10) = "*"
                    If Vung(i).Offset(, 2) = iMax Or Vung(i).Offset(0, 2) = iMin Then Vung(i).Offset(, 10) = "*"
                    a = a + 1
                 End If
             Else
                    If Vung(i) = Vung(i - 1) And Vung(i) <> Vung(i + 1) Then Vung(i).Offset(, 10) = "*"
                     a = a + 1
                
        End If
Next i
EndSub
Lần nữa xin cảm ơn bác ThuNghi Và bác concogia.
 
Upvote 0
sontvxd10 đã viết:
Code của bác OK rồi. Tiếc là em vẫn chưa dịch đc hết. Cái đối tượng "Object" này em ẫn chưa nắm đc. Để em viết lại theo hướng mà bác hướng dẫn xem sao. Có gì mong bác chỉ giáo thêm. Hy vọng 1 ngày nào đó đc giao lưu với bác. Em người xứ Quảng chắc khó mà gặp đc. Chúc bác và gia đình luôn mạnh khỏe.
Nhấp chuột vào đây để mở rộng...
Viết code theo hướng Match thì khó ở chỗ nếu MaxLoc và MinLoc sẽ có >1 lần ở cột Loc.
Tôi viết thử code theo hướng Match nhưng kết hợp thêm Find Methode. Với điều kiện LocTB xuất hiện liên tục. Còn không phải thêm 1 vòng lặp nữa để xác định M3 TB với LocTB.
Nghiên cứu thử xem. Có khi còn phức tạp hơn nghiên cứu Dictionary.
PHP: 
Option Explicit
Sub LocVung()
Dim rngBeam As Range, rngB As Range, rngLoc As Range, rngM As Range
Dim endR As Long, fR As Long, SoLan As Long, mR As Long, iMinLoc As Long, iMaxLoc As Long, iTbLoc As Long, iSL As Long, iL As Long, rTB As Long
Dim minLoc As Double, maxLoc As Double, tbLoc As Double, minTB As Double, maxTB As Double
Dim RngFound As Range
Dim Wf As WorksheetFunction
Set Wf = WorksheetFunction
With Sheets("Data")
  endR = .Cells(65000, 1).End(xlUp).Row
  Set rngBeam = .Range("A2:A" & endR) 'Beam
End With
Sheets("Data").Select
fR = 1: SoLan = 0
'MsgBox rngBeam.Count
Do While fR < rngBeam.Count + 1
  SoLan = Wf.CountIf(rngBeam, rngBeam(fR))
  Set rngB = rngBeam.Offset(fR - 1, 0).Resize(SoLan)
  Set rngLoc = rngB.Offset(, 2)
  'rngLoc.Select
  minLoc = Wf.min(rngLoc): maxLoc = Wf.max(rngLoc): tbLoc = Round((minLoc + maxLoc) / 2, 5)
  'Danh dau min
  iSL = Wf.CountIf(rngLoc, minLoc)
  Set RngFound = rngLoc(1)
  For iL = 1 To iSL
    Set RngFound = rngLoc.Find(What:=minLoc, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
      With RngFound
        .Offset(, 8) = "Min" 'Cot K
      End With
  Next iL
  'Danh dau max
  iSL = Wf.CountIf(rngLoc, maxLoc)
  Set RngFound = rngLoc(1)
  For iL = 1 To iSL
    Set RngFound = rngLoc.Find(What:=maxLoc, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
      With RngFound
        .Offset(, 8) = "Max" 'Cot K
      End With
  Next iL
  'Danh dau minTB, maxTB
  iSL = Wf.CountIf(rngLoc, tbLoc)
  If iSL > 0 Then
    rTB = Wf.Match(tbLoc, rngLoc, 0) - 1
    Set rngM = rngB.Offset(rTB, 8).Resize(iSL)
    rngM.Select
    minTB = Wf.min(rngM): maxTB = Wf.max(rngM)
    'danh dau minTB
    Set RngFound = rngM(1)
    Set RngFound = rngM.Find(What:=minTB, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
    With RngFound
      .Offset(, 2) = "MinTB" 'Cot K
    End With
    'danh dau maxTB
    Set RngFound = rngM(1)
    Set RngFound = rngM.Find(What:=maxTB, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
    With RngFound
      .Offset(, 2) = "MaxTB" 'Cot K
    End With
  End If
  fR = fR + SoLan
Loop
Set rngBeam = Nothing: Set rngB = Nothing: Set rngLoc = Nothing: Set rngM = Nothing
Set RngFound = Nothing: Set Wf = Nothing
End Sub
 

File đính kèm

  • TestTBMM02.rar
    61.9 KB · Đọc: 22
Upvote 0
Bác chỉ cho em hiểu nghĩa của câu lệnh này đc không?
Set RngFound = rngLoc.Find(What:=minLoc, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
 
Upvote 0
sontvxd10 đã viết:
Bác chỉ cho em hiểu nghĩa của câu lệnh này đc không?
Set RngFound = rngLoc.Find(What:=minLoc, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
Nhấp chuột vào đây để mở rộng...
Với Find Methode.
RngFound dịch thoáng là range tìm thấy được qua câu lênh
Set RngFound = rngLoc.Find(What:=minLoc, After:=RngFound, SearchOrder:=xlColumns, LookIn:=xlValues, LookAt:=xlWhole)
Nhấp chuột vào đây để mở rộng...
1/ Tìm trong rngLoc rngLoc.Find
2/ Tìm minLoc What:=minLo
3/ Tìm sau dòng 1 của rngLoc After:=RngFound
4/ Tìm theo cột SearchOrder:=xlColumns
5/ Tìm giá trị LookIn:=xlValues
6/ Tìm chính xác. LookAt:=xlWhole
Nếu rngFound ie tìm thấy thì lấy cái gì thì lấy từ vị trí rngFound.
Bạn nên tìm về Find Methode trên GPE một thời là thế mạnh. Tìm bài của hoangdanh282vn hay SA_DQ...
 
Upvote 0
Set rngBeam = Nothing: Set rngB = Nothing: Set rngLoc = Nothing: Set rngM = Nothing
Set RngFound = Nothing: Set Wf = Nothing
Những câu này để giải phóng bộ nhớ thôi ah bác? Với cái Dictionary Object này em chưa hiểu gì cả.
 
Lần chỉnh sửa cuối:
Upvote 0
Em muốn lấy dữ liệu cột thì như thế nào các Anh Chị...Ai biết chỉ dùm em...thanks nhiều
 

File đính kèm

  • lay noi luc cot max.rar
    182.5 KB · Đọc: 3
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

O
Kết hợp hàm value
Trả lời
0
Đọc
1
OANHMAI123
O
T
  • Question
Cho mình hỏi tại sao file mình chạy Sao lưu lại bị đầy bộ nhớ.
Trả lời
1
Đọc
30
BuiQuangThuan
B
Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
Trả lời
7
Đọc
154
Hoàng Tuấn 868
H
H
Kết nối vba với Database host (hiện tại đang làm host web)
2
Trả lời
26
Đọc
414
nguoiconxunui
N
A
Áp dụng Chiêu số 18: Điều khiển Conditional Formating bằng checkbox.
Trả lời
7
Đọc
130
AnhThu-1976
A
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