Xin giúp code VBA tìm số giữa giống nhau của các dãy số và tô màu chúng

hoang0569 · 8/11/20

Mình gửi File ví dụ, anh em xem giúp nhé, xin cảm ơn

SA_DQ · 8/11/20

Bạn thử với macro rùa bò này xem sao:

PHP:

Option Explicit
Sub TimSoGiuaGiongNhau()
 Dim J As Long, Dem As Integer
 Dim Rng As Range, sRng As Range, Tmp As Range
 Const MyColor As Byte = 34

 Set Rng = [D5].CurrentRegion
 For J = 0 To 9
    For Each sRng In Rng
        Dem = (sRng.Value \ (10) ^ 4) Mod 10
        If Dem = J Then
            If Tmp Is Nothing Then
                Set Tmp = sRng
            Else
                Set Tmp = Union(Tmp, sRng)
            End If
        End If
    Next sRng
    If Not Tmp Is Nothing Then
        If Tmp.Cells.Count > 1 Then
            Tmp.Interior.ColorIndex = MyColor + J
        End If
        Set Tmp = Nothing
    End If
 Next J
End Sub

hoang0569 · 8/11/20

Cảm ơn anh nhiều, chưa đúng lắm với ý muốn của e, nhưng như vậy cũng đã phân biệt được dãy số nào có số mình cần tìm. Anh em có thêm ý tưởng khác giúp mình tham khảo thêm nhé, xin cảm ơn.

Quang_Hải · 9/11/20

hoang0569 đã viết:
Mình gửi File ví dụ, anh em xem giúp nhé, xin cảm ơn

Thử thêm code này cho vui

Mã:

Sub To_Mau()
Dim sArr(), i, j, so_KT
so_KT = Val([A1].Value)
sArr = Range("D4:E9").Value
For i = 1 To UBound(sArr)
   For j = 1 To UBound(sArr, 2)
      If Val(Mid(sArr(i, j), 5, 1)) = so_KT Then
         Cells(i + 3, j + 3).Characters(5, 1).Font.ColorIndex = 3
      End If
   Next
Next
End Sub

Tuansparton · 9/11/20

SA_DQ đã viết:
Each sRng In Rng

SA_DQ đã viết:

Bạn thử với macro rùa bò này xem sao:

PHP:

Option Explicit
Sub TimSoGiuaGiongNhau()
Dim J As Long, Dem As Integer
Dim Rng As Range, sRng As Range, Tmp As Range
Const MyColor As Byte = 34

Set Rng = [D5].CurrentRegion
For J = 0 To 9
    For Each sRng In Rng
        Dem = (sRng.Value \ (10) ^ 4) Mod 10
        If Dem = J Then
            If Tmp Is Nothing Then
                Set Tmp = sRng
            Else
                Set Tmp = Union(Tmp, sRng)
            End If
        End If
    Next sRng
    If Not Tmp Is Nothing Then
        If Tmp.Cells.Count > 1 Then
            Tmp.Interior.ColorIndex = MyColor + J
        End If
        Set Tmp = Nothing
    End If
Next J
End Sub

hông thấy nó chạy bên sheet nào

hoang0569 · 9/11/20

quanghai1969 đã viết:

Thử thêm code này cho vui

Mã:

Sub To_Mau()
Dim sArr(), i, j, so_KT
so_KT = Val([A1].Value)
sArr = Range("D4:E9").Value
For i = 1 To UBound(sArr)
   For j = 1 To UBound(sArr, 2)
      If Val(Mid(sArr(i, j), 5, 1)) = so_KT Then
         Cells(i + 3, j + 3).Characters(5, 1).Font.ColorIndex = 3
      End If
   Next
Next
End Sub

Anh ơi, nếu A1=4 thì code không chạy nhỉ, anh xem lại giúp e, cảm ơn anh

batman1 · 9/11/20

Tôi đã thử thì cảm nhận là nếu trong các ô luôn là các số có nhiều chữ số mà ô được định dạng General hoặc Text thì có lúc tô mầu được có lúc không. Nếu như vậy thì không chấp nhận được vì đó là may rủi. Nhưng nếu ô chỉ cần định dạng General nhưng ô có chứa dấu nháy "'" ở đầu thì luôn thực hiện được. Và nếu ô chứa chữ thực sự vd. "hic hic" hoặc 123456a thì cũng luôn thực hiện được.

Câu hỏi:
1. Tại sao trong tập tin của mình bạn tô mầu chữ số 3 chỉ trong vài ô trong khi nhiều ô khác cũng có 3? Hay chỉ xét 3 ở vị trí thứ 5? Nếu thế thì mô tả còn thiếu vì bạn không đả động gì tới vị trí thứ 5.

2. A1 chứa SỐ hay CHỮ SỐ? Bạn nhập 3 nhưng nếu:
2a. Bạn chỉ chấp nhận CHỮ SỐ, tức không thể có vd. A1 = 13 thì thay cho SỐ phải ghi rõ là CHỮ SỐ.
2b. A1 là SỐ có 1 hoặc nhiều chữ số, tức có thể A1 = 13, thì mô tả và dữ liệu ví dụ phải đa dạng hơn.

Tóm lại mô tả phải ĐẦY ĐỦ và CHÍNH XÁC.

VetMini · 9/11/20

batman1 đã viết:
...Tóm lại mô tả phải ĐẦY ĐỦ và CHÍNH XÁC.

Tôi thì khó tính hơn bác mọt bậc.
Điều kiện code tô màu mẫu mã là phải "gỡ đi các mẫu mã tô trước đó".
Lỡ code chạy lần kế, dữ liệu khác đi nhưng màu vẫn còn đó?

batman1 · 9/11/20

VetMini đã viết:
Tôi thì khó tính hơn bác mọt bậc.
Điều kiện code tô màu mẫu mã là phải "gỡ đi các mẫu mã tô trước đó".
Lỡ code chạy lần kế, dữ liệu khác đi nhưng màu vẫn còn đó?

Cái này tôi lại yêu cầu ở người biết code. Vì theo lôgíc thì người viết code phải viết sao cho kết quả trả về đúng.

Nhiều người trên GPE viết code không có đoạn xóa kết quả cũ. Vì thế khi lọc mã vd. 12345 thì ra 1000 dòng dữ liệu. Sau khi nhập mã khác 67890 mà không có kết quả lọc thì người dùng vẫn nhìn thấy 1000 kết quả cũ. Nhưng tình huống này không nguy hiểm lắm. Vì người ta nhìn thấy rõ là không có sự thay đổi nên người ta ngạc nhiên và kiểm tra kỹ. Còn nếu mã 67890 có 200 dòng thì người ta nhìn thấy thấy rõ ràng có sự thay đổi. Nhưng ai biết rằng chỉ có 200 dòng có giá trị còn 800 dòng là rác. Trường hợp này mới nguy hiểm. Người ta rung đùi tưởng rằng mọi thứ ổn trong khi không ổn tí nào.

Trên GPE tôi thường đưa ra code đầy đủ. Bác có thể kiểm tra thấy là tôi luôn, nếu không 100% thì cũng 99%, xóa kết quả cũ. Vì tôi cho đấy là nhiệm vụ của người viết code.

hoang0569 · 9/11/20

Cảm ơn các anh đã quan tâm giúp, Tập tin của e là số hết và số cần tìm ứng với A1 luôn là số giữa của dãy số (có thể là 3,5,7,9...chữ số), xin hỏi anh batman1 , nếu e có sẵn cả mấy chục cột số như vậy, làm sao thêm dấu nháy hết đc anh, chỉe với, cảm ơn các anh

batman1 · 9/11/20

hoang0569 đã viết:
Cảm ơn các anh đã quan tâm giúp, Tập tin của e là số hết và số cần tìm ứng với A1 luôn là số giữa của dãy số (có thể là 3,5,7,9...chữ số), xin hỏi anh batman1 , nếu e có sẵn cả mấy chục cột số như vậy, làm sao thêm dấu nháy hết đc anh, chỉe với, cảm ơn các anh

Chạy code sau. Hiện tại là Sheet1 và vùng D4:E9. Nếu khác thì sửa lại trong code. Lưu ý là nhập vùng có ít nhất 2 ô. Có thể nhập thừa, vd. trong tập tin của bạn có thể nhập vd. B2:G100 dù chỉ trong D4:E9 có dữ liệu.

Mã:

Sub them_nhay()
Dim r As Long, c As Long, Arr()
    With ThisWorkbook.Worksheets("Sheet1")
        Arr = .Range("D4:E9").Value
        For r = 1 To UBound(Arr, 1)
            For c = 1 To UBound(Arr, 2)
                If Len(Arr(r, c)) Then Arr(r, c) = "'" & Arr(r, c)
            Next c
        Next r
        .Range("D4:E9").Value = Arr
    End With
End Sub

Sau khi có dữ liệu số với dấu nháy ở đầu thì chạy code sau.
Lưu ý:
- trong A1 là số có 1 hoặc nhiều chữ số, vd. A1 = 53.
- nếu trong ô có 2, 3, ... đoạn có số cần tìm thì tô mầu tất cả. Code tô mầu cả ở ĐẦU nếu tìm thấy. Nếu tìm thấy cả ở đầu nhưng không tô mầu ở đầu thì sửa Do While pos > 0 thành Do While pos > 1
- khi chạy code thì chọn ô có chứa giá trị cần tìm, vì trong tậptin khác có thể ở ô khác A1.
- tiếp theo chọn vùng dữ liệu, vì ở tập tin khác có thể khác D4:E9.

Mã:

Sub ToMauGiaTri()
Dim pos As Long, a As Long, text As String, findValue As String, myRange, cell_ As Range
    On Error Resume Next
    Set myRange = Application.InputBox(prompt:="Hay chon o chua gia tri can tim", Type:=8)  ' chọn ô có chứa giá trị cần tìm
    On Error GoTo 0
    If IsEmpty(myRange) Then Exit Sub
    findValue = Trim(myRange(1).Value) ' giá trị cần tìm. Nếu chọn nhiều hơn 1 ô thì lấy ô ở góc trên bên trái
    a = Len(findValue)
    If a = 0 Then Exit Sub
    Set myRange = Application.InputBox(prompt:="Hay chon vung du lieu", Type:=8)    ' chọn vùng dữ liệu
    On Error GoTo 0
    If IsEmpty(myRange) Then Exit Sub   ' nếu không chọn vùng dữ liệu thì dọn đồ chơi
    For Each cell_ In myRange   ' xét từng ô trong vùng đã chọn
        text = cell_.Value  ' giá trị của ô đang xét
        cell_.Characters(1, Len(cell_.Value)).Font.Color = RGB(0, 0, 0) ' trước hết xóa mầu trước đó đã tô (kết quả của lần tìm trước)
        pos = InStr(1, text, findValue, vbTextCompare)  ' tìm giá trị cho trước
        Do While pos > 0    ' nếu tìm thấy
            cell_.Characters(pos, a).Font.Color = RGB(255, 0, 0)    ' tô mầu
            pos = InStr(pos + a, text, findValue, vbTextCompare)    ' tìm tiếp giá trị cho trước
        Loop
    Next cell_
End Sub

Nhattanktnn · 10/11/20

batman1 đã viết:
Chạy code sau. Hiện tại là Sheet1 và vùng D4:E9. Nếu khác thì sửa lại trong code. Lưu ý là nhập vùng có ít nhất 2 ô. Có thể nhập thừa, vd. trong tập tin của bạn có thể nhập vd. B2:G100 dù chỉ trong D4:E9 có dữ liệu.

Mã:

Sub them_nhay() Dim r As Long, c As Long, Arr() With ThisWorkbook.Worksheets("Sheet1") Arr = .Range("D4:E9").Value For r = 1 To UBound(Arr, 1) For c = 1 To UBound(Arr, 2) If Len(Arr(r, c)) Then Arr(r, c) = "'" & Arr(r, c) Next c Next r .Range("D4:E9").Value = Arr End With End Sub

Sau khi có dữ liệu số với dấu nháy ở đầu thì chạy code sau.
Lưu ý:
- trong A1 là số có 1 hoặc nhiều chữ số, vd. A1 = 53.
- nếu trong ô có 2, 3, ... đoạn có số cần tìm thì tô mầu tất cả. Code tô mầu cả ở ĐẦU nếu tìm thấy. Nếu tìm thấy cả ở đầu nhưng không tô mầu ở đầu thì sửa Do While pos > 0 thành Do While pos > 1
- khi chạy code thì chọn ô có chứa giá trị cần tìm, vì trong tậptin khác có thể ở ô khác A1.
- tiếp theo chọn vùng dữ liệu, vì ở tập tin khác có thể khác D4:E9.

Mã:

Sub ToMauGiaTri() Dim pos As Long, a As Long, text As String, findValue As String, myRange, cell_ As Range On Error Resume Next Set myRange = Application.InputBox(prompt:="Hay chon o chua gia tri can tim", Type:=8) ' chọn ô có chứa giá trị cần tìm On Error GoTo 0 If IsEmpty(myRange) Then Exit Sub findValue = Trim(myRange(1).Value) ' giá trị cần tìm. Nếu chọn nhiều hơn 1 ô thì lấy ô ở góc trên bên trái a = Len(findValue) If a = 0 Then Exit Sub Set myRange = Application.InputBox(prompt:="Hay chon vung du lieu", Type:=8) ' chọn vùng dữ liệu On Error GoTo 0 If IsEmpty(myRange) Then Exit Sub ' nếu không chọn vùng dữ liệu thì dọn đồ chơi For Each cell_ In myRange ' xét từng ô trong vùng đã chọn text = cell_.Value ' giá trị của ô đang xét cell_.Characters(1, Len(cell_.Value)).Font.Color = RGB(0, 0, 0) ' trước hết xóa mầu trước đó đã tô (kết quả của lần tìm trước) pos = InStr(1, text, findValue, vbTextCompare) ' tìm giá trị cho trước Do While pos > 0 ' nếu tìm thấy cell_.Characters(pos, a).Font.Color = RGB(255, 0, 0) ' tô mầu pos = InStr(pos + a, text, findValue, vbTextCompare) ' tìm tiếp giá trị cho trước Loop Next cell_ End Sub

Vậy là sử dụng range.characters không hoạt động với ô dạng số, vậy bác Batman1 cho em hỏi, trường hợp nếu ta muốn tô màu cho vùng chứa số, nhưng không được phép chuyển về dạng chuỗi (giả sử như đang có công thức liên kết với nó) thì giải quyết thế nào?

Xin giúp code VBA tìm số giữa giống nhau của các dãy số và tô màu chúng

hoang0569

Thành viên thường trực

File đính kèm

SA_DQ

/(hông là gì!

hoang0569

Thành viên thường trực

Quang_Hải

Thành viên gạo cội

Tuansparton

Thành viên mới

hoang0569

Thành viên thường trực

batman1

Thành viên gạo cội

VetMini

Ăn cùng góc phố

batman1

Thành viên gạo cội

hoang0569

Thành viên thường trực

batman1

Thành viên gạo cội

Nhattanktnn

Thành viên gắn bó

Bài viết mới nhất

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