Code trả kết quả không đúng?

[NH_DK]

Lâu lâu rùi hôm này em mới làm đến cái này. Nhưng không hiểu sao mà nó chạy không cho kết quả đúng? Mọi người xem giúp em nhé!

 

[ndu96081631]

Lâu lâu rùi hôm này em mới làm đến cái này. Nhưng không hiểu sao mà nó chạy không cho kết quả đúng? Mọi người xem giúp em nhé!

Câu

If S1.Range(S1.[D2], S1.[D65000].End(3)).Find(Target) = 0 Then

là không đúng
Find Method trả về kết quả là Range ---> Để xác định Range ấy có tồn tại hay không phải dùng:

If S1.Range(S1.[D2], S1.[D65000].End(3)).Find(Target) Is Nothing Then

------------------------

With S1.Range(S1.[A[B][COLOR=red]2[/COLOR][/B]], S1.[A65000].End(3)).Resize(, 8)
  .AutoFilter .....
End With

AutoFilter với tiêu đề là dòng 2 à? ---> Sửa số 2 thành 1 nhé
Và vì sửa 2 thành 1 nên đoạn:

Union(.Offset(, 1).Resize(, 2), .Offset(, 4).Resize(, 4)).SpecialCells(12).Copy Range("A[COLOR=red][B]8[/B][/COLOR]")

phải sửa thành

Union(.Offset(, 1).Resize(, 2), .Offset(, 4).Resize(, 4)).SpecialCells(12).Copy Range("A[COLOR=red][B]7[/B][/COLOR]")

---------------------------------------
Còn tôi thì sẽ làm vầy:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim fRng As Range
  'On Error Resume Next
  If Target.Address = "$D$5" Then
    Set fRng = S1.Range("D:D").Find(Target, , xlValues, xlWhole)
    If fRng Is Nothing Then
      MsgBox "Khong co ma hang nay. Vui long nhap lai nhe!", , "Thông báo"
    Else
     Range("A8:F10000").Clear
      With S1.Range("A1:H10000")
        .AutoFilter 1, ">=" & CLng(Range("D3").Value), 1, "<=" & CLng(Range("D4").Value)
        .AutoFilter 4, Target
        Union(.Offset(, 1).Resize(, 2), .Offset(, 4).Resize(, 4)).SpecialCells(12).Copy Range("A7")
        .AutoFilter
      End With
    End If
  End If
End Sub

Với AutoFilter thì chẳng cần tính toán quá về giới hạn vùng dữ liệu (khỏi cần .End(3)...)

 

[ptm0412]

Kết quả không đúng chỗ nào? Không đúng trình tự thời gian là sao? Tôi thấy đúng trình tự thời gian (từ nhỏ đến lớn) rồi.

Có 1 chỗ sai, không liên quan đến thời gian, đó là dù chọn ngày bắt đầu là ngày nào đi nữa, thì vẫn có 1 dòng ngày 1/6/2011.
Muốn biết vì sao sai thì xoá bỏ dòng cuối:

                .AutoFilter

Chạy code, rồi qua sheet data nhìn sẽ thấy.

 

[Ếch Xanh]

Lâu lâu rùi hôm này em mới làm đến cái này. Nhưng không hiểu sao mà nó chạy không cho kết quả đúng? Mọi người xem giúp em nhé!

Bạn thử với code này xem:

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  With S1.Range(S1.[A1], S1.[A65536].End(xlUp))
    If Target.Address = "$D$5" Then
      If .Offset(, 3).Find(Target) Is Nothing Then _
        MsgBox "Khong co ma hang nay. Vui long nhap lai nhe!", , "Thong bao": Exit Sub
      [A8:F65536].ClearContents
      With .Resize(, 8)
        .AutoFilter 4, Target
        .AutoFilter 3, ">=" & [D3], 12, "<=" & [D4]
      End With
      Union(.Offset(1, 1).Resize(, 2), .Offset(1, 4).Resize(, 4)).Copy [A8]
      .AutoFilter
    End If
  End With
End Sub

Tôi đang tự hỏi bạn nên dùng xlAnd hay xlOr, còn tôi thì dùng xlOr mới cho ra giá trị đúng.

 

[ndu96081631]

Bạn thử với code này xem:

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  With S1.Range(S1.[A1], S1.[A65536].End(xlUp))
    If Target.Address = "$D$5" Then
      If .Offset(, 3).Find(Target) Is Nothing Then _
        MsgBox "Khong co ma hang nay. Vui long nhap lai nhe!", , "Thong bao": Exit Sub
      [A8:F65536].ClearContents
      With .Resize(, 8)
        .AutoFilter 4, Target
        .AutoFilter 3, ">=" & S2.[D3], 12, "<=" & S2.[D4]
      End With
      Union(.Offset(1, 1).Resize(, 2), .Offset(1, 4).Resize(, 4)).Copy [A8]
      .AutoFilter
    End If
  End With
End Sub

Hãy cần thận với phép so sánh này:

AutoFilter 3, [COLOR=red]">=" & S2.[D3][/COLOR], 12, [COLOR=red]"<=" & S2.[D4][/COLOR]

Với AutoFilter ngày tháng thì nhất định phải lồng CDbl hoặc CLng vào giá trị so sánh để tránh sai sót
(Vụ này nói hoài)

 

[Ếch Xanh]

Hãy cần thận với phép so sánh này:

AutoFilter 3, [COLOR=red]">=" & S2.[D3][/COLOR], 12, [COLOR=red]"<=" & S2.[D4][/COLOR]

Với AutoFilter ngày tháng thì nhất định phải lồng CDbl hoặc CLng vào giá trị so sánh để tránh sai sót
(Vụ này nói hoài)

Vâng, cám ơn Thầy, em sẽ sửa lại như vầy:

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  With S1.Range(S1.[A1], S1.[A65536].End(xlUp))
    If Target.Address = "$D$5" Then
      If .Offset(, 3).Find(Target) Is Nothing Then _
        MsgBox "Khong co ma hang nay. Vui long nhap lai nhe!", , "Thong bao": Exit Sub
      [A8:F65536].ClearContents
      With .Resize(, 8)
        .AutoFilter 4, Target
        .AutoFilter 3, ">=" & CLng([D3]), 12, "<=" & CLng([D4])
      End With
      Union(.Offset(1, 1).Resize(, 2), .Offset(1, 4).Resize(, 4)).Copy [A8]
      .AutoFilter
    End If
  End With
End Sub

 

[ndu96081631]

Vâng, cám ơn Thầy, em sẽ sửa lại như vầy:

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  With S1.Range(S1.[A1], S1.[A65536].End(xlUp))
    If Target.Address = "$D$5" Then
      If .Offset(, 3).Find(Target) Is Nothing Then _
        MsgBox "Khong co ma hang nay. Vui long nhap lai nhe!", , "Thong bao": Exit Sub
      [A8:F65536].ClearContents
      With .Resize(, 8)
        .AutoFilter 4, Target
        .AutoFilter 3, ">=" & CLng([D3]), 12, "<=" & CLng([D4])
      End With
      Union(.Offset(1, 1).Resize(, 2), .Offset(1, 4).Resize(, 4)).Copy [A8]
      .AutoFilter
    End If
  End With
End Sub

Câu lệnh này:

Union(.Offset(1, 1).Resize(, 2), .Offset(1, 4).Resize(, 4)).Copy [A8]

Dù không nói gì thì ngầm định Excel cũng hiểu là SpecialCells(12).Copy ---> Mà đã dùng đến SpecialCells thì sẽ không tránh được lỗi xảy ra với dữ liệu lớn ---> Trường hợp lỗi xuất hiện thì nó sẽ copy tất tần tật sang Range("A8") (chẳng lọc gì cả)
----------------------
Với dữ liệu cực lớn ta nên dùng Array để tránh lỗi, đồng thời để tăng tốc độ.
Nhân tiện, tặng các bạn "trò chơi" này

Function Filter2DArray(ByVal sArray, ByVal ColIndex As Long, ByVal FindStr As String, ByVal HasTitle As Boolean)
  Dim TmpArr, i As Long, j As Long, Arr, Dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set Dic = CreateObject("Scripting.Dictionary")
  TmpArr = sArray
  ColIndex = ColIndex + LBound(TmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(TmpArr, 1) - HasTitle To UBound(TmpArr, 1)
    If Chk Then
      TmpVal = CDbl(TmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then Dic.Add i, ""
    Else
      If UCase(TmpArr(i, ColIndex)) Like UCase(FindStr) Then Dic.Add i, ""
    End If
  Next
  If Dic.Count > 0 Then
    Tmp = Dic.Keys
    ReDim Arr(LBound(TmpArr, 1) To UBound(Tmp) + LBound(TmpArr, 1) - HasTitle, LBound(TmpArr, 2) To UBound(TmpArr, 2))
    For i = LBound(TmpArr, 1) - HasTitle To UBound(Tmp) + LBound(TmpArr, 1) - HasTitle
      For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
        Arr(i, j) = TmpArr(Tmp(i - LBound(TmpArr, 1) + HasTitle), j)
      Next
    Next
    If HasTitle Then
      For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
        Arr(LBound(TmpArr, 1), j) = TmpArr(LBound(TmpArr, 1), j)
      Next
    End If
  End If
  Filter2DArray = Arr
End Function

Xem chi tiết tại đây:
http://www.giaiphapexcel.com/forum/showthread.php?47929-Sort-m%E1%BA%A3ng-2-chi%E1%BB%81u
Áp dụng vào file của tác giả:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim fRng As Range, Arr, sArray
  If Target.Address = "$D$5" Then
    Range("A7:H10000").ClearContents
    sArray = S1.Range("A1").CurrentRegion.Value
    Arr = Filter2DArray(sArray, 1, ">=" & CDbl(Range("D3").Value), True)
    Arr = Filter2DArray(Arr, 1, "<=" & CDbl(Range("D4").Value), True)
    Arr = Filter2DArray(Arr, 4, Target.Value, True)
    If IsArray(Arr) Then Range("A7").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
  End If
End Sub

Bảo đảm tốc độ cực khủng ---> Hãy thí nghiệm với dữ liệu > 20,000 dòng để trải nghiệm