Tìm ra giá trị khác trong cột bằng vba

[tuanthuy1012]

Chào các anh chị

Em có file tài liệu : Cột giá của từng đơn hàng sẽ là giống nhau. Tuy nhiên em muốn kiểm tra xem nó có bị sai chổ nào không.
ví dụ: Nếu H2:H11 cùng giá trị thì lấy ô giá trị H2
Nếu H16:H24 có 1,2... giá trị khác thì điền vào là "sai"
Kết quả em mong muốn sẽ như sheet ketqua ạ
Em cảm ơn anh chị rất nhiều>

 

[snow25]

Chào các anh chị

Em có file tài liệu : Cột giá của từng đơn hàng sẽ là giống nhau. Tuy nhiên em muốn kiểm tra xem nó có bị sai chổ nào không.
ví dụ: Nếu H2:H11 cùng giá trị thì lấy ô giá trị H2
Nếu H16:H24 có 1,2... giá trị khác thì điền vào là "sai"
Kết quả em mong muốn sẽ như sheet ketqua ạ
Em cảm ơn anh chị rất nhiều>

Đây bạn xem.

Sub ketqua()
Dim arr, arr1
Dim a As Long, i As Long, j As Long, b As Long, c As Long
Dim dic As Object
Dim dk As String, s1 As String
Set dic = CreateObject("SCripting.Dictionary")
With Sheet1
   s1 = .Range("B1").Value
   c = .Range("B" & Rows.Count).End(xlUp).Row
   arr = .Range("A2:H" & c).Value
   ReDim arr1(1 To UBound(arr, 1), 1 To 8)
   For i = 1 To UBound(arr, 1)
       dk = arr(i, 2)
       If Len(dk) <> 0 And UCase(dk) <> UCase(s1) Then
          If dic.exists(dk) = 0 Then
              a = a + 1
             arr1(a, 1) = a
             arr1(a, 2) = dk
             arr1(a, 8) = arr(i, 8)
             dic.Item(dk) = Array(a)
         Else
             b = dic.Item(dk)(0)
             If arr(i, 8) <> arr1(b, 8) Then arr1(b, 8) = "Sai"
       End If
       End If
   Next i
End With
With Sheet2
     .Range("A9").Resize(a, 8).Value = arr1
End With
End Sub

 

[SA_DQ]

Bạn thử với macro sự kiện này như là 1 tham góp, dù chậm trễ!:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B2]) Is Nothing Then
    Dim Rng As Range, sRng As Range
    Dim MyAdd As String:                                Dim DGia As Double, Rws As Long

    With Sheets("T12")
        Rws = .[B65500].End(xlUp).Row
        Set Rng = .[B1].Resize(Rws)
        Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
        If sRng Is Nothing Then
            MsgBox "Nothing", , "GPE.COM Xin Luu Ý!"
        Else
            MyAdd = sRng.Address
            Do
                If DGia = 0 Then
                    DGia = .Cells(sRng.Row, "H").Value
                    Cells(2, "H").Value = DGia
                ElseIf DGia <> 0 And .Cells(sRng.Row, "H").Value <> DGia Then
                    Cells(2, "H").Value = "Sai":            Exit Do
                End If
                Set sRng = Rng.FindNext(sRng)
            Loop While sRng.Address <> MyAdd
       End If
    End With
End If
End Sub

 

[tuanthuy1012]

Đây bạn xem.
cám ơn bác em làm đc rồi .
em có thêm trường hợp này cũng tương tự anh/chị xem thêm giúp em với. kết quả bên sheet 2
Em cám ơn nhiều

 

[Ba Tê]

em có thêm trường hợp này cũng tương tự anh/chị xem thêm giúp em với. kết quả bên sheet 2

Chẳng thấy tương tự là sao, lấy kết quả từ Sheet1 sang Sheet2 như kết quả mẫu?
Nếu vậy thì không "tương tự" với bài #1 chút nào.

 

[snow25]

Chẳng thấy tương tự là sao, lấy kết quả từ Sheet1 sang Sheet2 như kết quả mẫu?
Nếu vậy thì không "tương tự" với bài #1 chút nào.

Đây là bạn đấy muốn kết quả tương tự như bài 1.Còn dữ liệu khác bài 1.Bác à.