Lọc dữ liệu cho kết quả bằng màu sắc

[beckcuong80]

Em mới bắt đầu học VB. Em có một bài toán nhờ các anh chị giúp cho code của nó. Bài toán như sau:
Ở sheet 1 em có dữ liệu là các con số. em muốn lọc các số đó ra ở sheet 2 như sau:
Bước 1: lọc các số có ở trong sheet 1 (dòng 1 : từ A1 đến F1) cho kết quả ở sheet 2 tại các vị trí đã đc định sẵn (xem file đính kèm) bằng màu xanh da trời.
Bước 2: lọc các số ở trong sheet 1 (cả dòng 1 và dòng 2: vùng từ A1 đến F2) cho kết quả ở sheet 2 tại các vị trí đã đc định sẵn (xem file đính kèm) bằng màu xanh da trời. Các số trùng nhau (ví dụ số 12) đề đc thể hiện tại 1 vị trí

 

[ptm0412]

Xem code trong file đính kèm

 

[Po_Pikachu]

Tại sao lại phải chia ra hai bước vậy bạn?
Vì bước 2 có cả bước 1 trong đó rồi lặp lại làm gì?
Vậy làm bước 2 thôi nha!
Code vầy thôi bác ơi!

Sub chay()
For Each cel In Cells.SpecialCells(2)
    k = Format(cel, "00")
    Sheet2.Cells(Val(Left(k, 1)) + 2, Val(Right(k, 1)) + 2).Interior.ColorIndex = 5
Next
End Sub

Thân.

 

[ptm0412]

To PoPikachu:
Làm cho bài bản tí, biết đâu trong sheet1 lại còn dữ liệu khác, cái SpecialCells() làm sao loại trừ?

 

[ChanhTQ@]

Đây sẽ là macro của bước một, mời bạn kiểm tra lại

Option Explicit
Sub NumToColorCells()
 Dim Rng As Range, Clls As Range, cRng As Range
 Dim Col As Byte
 
 Set Rng = Sheets("Sheet2").[B2].CurrentRegion
 For Each Clls In Rng
    If Clls.Interior.ColorIndex = 5 Then
        If cRng Is Nothing Then
            Set cRng = Clls
        Else
            Set cRng = Union(cRng, Clls)
    End If:         End If
 Next Clls
 cRng.NumberFormat = "0"
 Set Rng = Sheets("sheet1").Range("A1:A" & [iV1].End(xlToLeft).Columns)
 For Each Clls In cRng
    Clls.Value = Rng.Offset(, Col).Value
    Col = Col + 1    
 Next Clls
End Sub

 

[ndu96081631]

Bài này chỉ cần Conditional Formating là được, không cần bất cứ code nào
- Tại sheet1, đặt 1 name:
DL =Sheet1!$A$1:$F$1000
- Tại sheet2, quét chọn B2:K11 ---> Vào menu Format\Conditional Formating và thiết lập công thức
=COUNTIF(DL,B$1+$A2*10)
- Tô màu tuy ý
Vậy là xong!
Màu sẽ luôn được cập nhất chính xác mổi khi sheet1 có nhập mới hoặc thay đổi dử liệu
Và nếu dùng cách này biến đổi thành code thì cũng không cần vòng lập For luôn ---> Nhanh gọn

 

[ChanhTQ@]

Hoặc mình không hiểu đúng đề, hoặc là các bạn trật lất!

Mình hiểu là phải chép các dữ liệu bên Sheet1 sang các ô đang được tô màu của Sheet2

Sub NumToColorCells()
 Const pC As String = "@"
 Dim Rng As Range, Clls As Range, cRng As Range
 Dim Cot As Byte
 Dim StrC As String
 
 Set Rng = Sheets("Sheet2").[B2].CurrentRegion
 For Each Clls In Rng
    If Clls.Interior.ColorIndex = 5 Then
        If cRng Is Nothing Then
            Set cRng = Clls
        Else
            Set cRng = Union(cRng, Clls)
    End If:         End If
 Next Clls
 cRng.NumberFormat = "0"
 With Sheets("sheet1")
    Cot = .[iV2].End(xlToLeft).Column
    Set Rng = .Range(.Cells(1, 1), .Cells(2, Cot))
 End With
 For Each Clls In Rng
    If InStr(StrC, pC & Clls.Value & pC) = 0 Then
        StrC = StrC & pC & Clls.Value
    Else
    End If
 Next Clls
 StrC = Mid(StrC, 2) & pC & "GPE.COM"
 For Each Clls In cRng
    Cot = InStr(1, StrC, pC)
    If Cot > 0 Then
        Clls.Value = Left(StrC, Cot - 1)
        StrC = Mid(StrC, Cot + 1)
    End If
 Next Clls
End Sub

 

[ndu96081631]

Mình hiểu là phải chép các dữ liệu bên Sheet1 sang các ô đang được tô màu của Sheet2

Sub NumToColorCells()
 Const pC As String = "@"
 Dim Rng As Range, Clls As Range, cRng As Range
 Dim Cot As Byte
 Dim StrC As String
 
 Set Rng = Sheets("Sheet2").[B2].CurrentRegion
 For Each Clls In Rng
    If Clls.Interior.ColorIndex = 5 Then
        If cRng Is Nothing Then
            Set cRng = Clls
        Else
            Set cRng = Union(cRng, Clls)
    End If:         End If
 Next Clls
 cRng.NumberFormat = "0"
 With Sheets("sheet1")
    Cot = .[iV2].End(xlToLeft).Column
    Set Rng = .Range(.Cells(1, 1), .Cells(2, Cot))
 End With
 For Each Clls In Rng
    If InStr(StrC, pC & Clls.Value & pC) = 0 Then
        StrC = StrC & pC & Clls.Value
    Else
    End If
 Next Clls
 StrC = Mid(StrC, 2) & pC & "GPE.COM"
 For Each Clls In cRng
    Cot = InStr(1, StrC, pC)
    If Cot > 0 Then
        Clls.Value = Left(StrC, Cot - 1)
        StrC = Mid(StrC, Cot + 1)
    End If
 Next Clls
End Sub

Anh ơi! Nếu thật sự anh hiểu đúng vấn đề thì lại càng không cần code. ---> Em có thể dùng 1 công thức nhỏ bằng móng tay là ra (COUNTIF)

 

[ChanhTQ@]

Các số trùng nhau (ví dụ số 12) đề đc thể hiện tại 1 vị trí

 Theo mình hiểu, bên S1 có 2 số 12 thì bên s2 chỉ 1 ô chứa số này mà thôi!

Chú mày làm được cái này nữa thì 'Tau' mới chịu thua!

 

[beckcuong80]

Cám ơn các bạn đã giúp đỡ!

 

[ChanhTQ@]

Tiếp tục rút gọn code một tẹo

Sub NumsToColorCells()
 Const pC As String = "@"
 Dim Rng As Range, Clls As Range, cRng As Range, Cll As Range
 Dim Cot As Byte:                       Dim StrC As String
 
 Set Rng = Sheets("Sheet2").[B2].CurrentRegion
 For Each Clls In Rng
    If Clls.Interior.ColorIndex = 5 Then
        If cRng Is Nothing Then
            Set cRng = Clls
        Else
            Set cRng = Union(cRng, Clls)
    End If:         End If
 Next Clls
 cRng.NumberFormat = "0"
 With Sheets("sheet1")
    Cot = .[iV2].End(xlToLeft).Column
    Set Rng = .Range(.Cells(1, 1), .Cells(2, Cot))
 End With
 StrC = "GPE.COM" & pC
 For Each Clls In cRng
    For Each Cll In Rng
        If InStr(1, StrC, pC & Cll.Value & pC) = 0 Then
            StrC = StrC & Cll.Value & pC
            Clls.Value = Cll.Value:         Exit For
        End If
    Next Cll
 Next Clls
End Sub