Lọc dữ liệu tự động từ Insert Comment ... (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
A

Anti-Plus

Thành viên chính thức
Tham gia
25/3/08
Bài viết
65
Được thích
8
Xin chào các bro,

Rất mong các bro hướng dẫn mình cách lọc dữ liệu từ Comment. Ví dụ cụ thể như sau :

- Mình có ô C2 đã được insert comment như hình ảnh minh họa bên dưới.
- & ô B2 dùng để tự động lọc những giá trị từ ô C2 trong comment với những giá trị gồm 2 chữ số cuối cùng có giá trị là số lẻ (nghĩa là 2 số cuối cùng không chia hết cho 2) như hình ảnh minh họa bên dưới.

Rất mong các bro giúp mình nhé ... Xin cám ơn !

comment.jpg
 
Anti-Plus đã viết:
Xin chào các bro,

Rất mong các bro hướng dẫn mình cách lọc dữ liệu từ Comment. Ví dụ cụ thể như sau :

- Mình có ô C2 đã được insert comment như hình ảnh minh họa bên dưới.
- & ô B2 dùng để tự động lọc những giá trị từ ô C2 trong comment với những giá trị gồm 2 chữ số cuối cùng có giá trị là số lẻ (nghĩa là 2 số cuối cùng không chia hết cho 2) như hình ảnh minh họa bên dưới.

Rất mong các bro giúp mình nhé ... Xin cám ơn !
Nhấp chuột vào đây để mở rộng...

oh, bạn upload file lên nhé, và mô tả rõ nên nhẹ
thế thành viên # mới giúp được
.
 
Lần chỉnh sửa cuối:
Bạn dùng macro sau

PHP: 
Option Explicit

Sub CopyCommLeftCell()
' The following macro will copy comment text to the cell to the left, _
    if that cell is empty.' 
 Dim CommRng As Range, myCell As Range
 Dim curWks As Worksheet
 Dim bVTr As Byte, DDai As Byte
 Dim StrM As String, StrC As String, StrL As String
 
  Application.ScreenUpdating = False
  Set curWks = ActiveSheet:                 On Error Resume Next
  Set CommRng = curWks.Cells.SpecialCells(xlCellTypeComments)
  On Error GoTo 0
  If CommRng Is Nothing Then
     MsgBox "No comments found":            Exit Sub
  End If
  For Each myCell In CommRng
    StrC = myCell.Comment.Text:             DDai = Len(StrC)
    If myCell.Offset(, -1) <> "" Then GoTo 26
    For bVTr = 1 To DDai
        If IsNumeric(Mid(StrC, bVTr, 1)) Then
            If Len(StrM) < 1 Then
                StrM = Mid(StrC, bVTr, 1)
            Else
                StrM = StrM & Mid(StrC, bVTr, 1)
            End If
        Else
            If Len(StrM) > 1 Then
                If CInt(Right(StrM, 2)) Mod 2 = 1 Then _
                    StrL = StrL & " " & Right(StrM, 2)
                StrM = ""
            End If
        End If
    Next bVTr
    myCell.Offset(, -1) = StrL:                    StrL =""
26  Next myCell
  
End Sub
 
@SA_DQ : Macro đó sử dụng sao hả bro ? Bro có thể hướng dẫn chi tiết hơn cách dùng macro đó luôn không ? vì mình cũng là lính mới trong excel, Thanks !!!
 
Lần chỉnh sửa cuối:
@SA_DQ : Macro của bro đưa ra đã đúng theo nhu cầu của mình rồi. Xin chân thành cám ơn sự nhiệt tình giúp đỡ của bro.

Một lần nữa mình rất mong bro giúp đỡ mình thêm 1 chút xíu nữa nhé.

- Cũng macro trên & mình vẫn lọc y như y/c trên nhưng mình sẽ lọc loại bỏ qua những số có 2 số cuối cùng là 1 (cụ thể là những cặp số : 01, 11, 21, 31, 41, 51, 61, 71, 81, 91) & 2 số cuối cùng là những số cặp lẻ (cụ thể là những cặp số : 11, 33, 55, 77, 99).

- Vd theo hình ảnh mình họa dưới đây thì ô B2 sẽ tự động lọc ra là : 19 25 19 45 63

comment.jpg

- & thêm 1 Y/C nữa là ô D2 sẽ tự động điền số thuộc về tổng của ô B2, vd theo hình ảnh minh họa ở trên thì ô D2 sẽ tự động điền vào là 5 (5 nghĩa là ô B2 có tổng cộng 5 cặp số).

Xin chân thành cám ơn bro SA_DQ rất nhiều !
 
Anti-Plus đã viết:
@SA_DQ : Macro của bro đưa ra đã đúng theo nhu cầu của mình rồi. Xin chân thành cám ơn sự nhiệt tình giúp đỡ của bro.
Nhấp chuột vào đây để mở rộng...
Hãy nhấn vô nút Thanks là đủ rồi!


Một lần nữa mình rất mong bro giúp đỡ mình thêm 1 chút xíu nữa nhé.

- Cũng macro trên & mình vẫn lọc y như y/c trên nhưng mình sẽ lọc loại bỏ qua những số có 2 số cuối cùng là 1 (cụ thể là những cặp số : 01, 11, 21, 31, 41, 51, 61, 71, 81, 91) & 2 số cuối cùng là những số cặp lẻ (cụ thể là những cặp số : 11, 33, 55, 77, 99).

- Vd theo hình ảnh mình họa thì ô B2 sẽ tự động lọc ra là : 19 25 19 45 63
- & thêm 1 Y/C nữa là ô D2 sẽ tự động điền tổng các số của ô B2, vd theo hình ảnh minh họa ở trên thì ô D2 sẽ tự động điền vào là 5 (5 nghĩa là ô B2 có tổng cộng 5 cặp số).
Xin chân thành cám ơn bro SA_DQ rất nhiều !
Nhấp chuột vào đây để mở rộng...

PHP: 
Option Explicit

Sub CopyCommLeftCell()
 Dim CommRng As Range, myCell As Range
 Dim curWks As Worksheet
 Dim bVTr As Byte, DDai As Byte, bCount As Byte, SoCuoi As Integer
 Dim STemp As String, StrC As String, StrL As String
 
  Application.ScreenUpdating = False
  Set curWks = ActiveSheet:                 On Error Resume Next
  Set CommRng = curWks.Cells.SpecialCells(xlCellTypeComments)
  On Error GoTo 0
  If CommRng Is Nothing Then
     MsgBox "No comments found":            Exit Sub
  End If
  For Each myCell In CommRng
    StrC = myCell.Comment.Text:             DDai = Len(StrC)
    If myCell.Offset(, -1) <> "" Then GoTo 27
    For bVTr = 1 To DDai
        If IsNumeric(Mid(StrC, bVTr, 1)) Then
            STemp = STemp & Mid(StrC, bVTr, 1)
        Else
            If Len(STemp) > 1 Then
                SoCuoi = CInt(Right(STemp, 2))
                If SoCuoi Mod 2 = 1 And Not NoSelect(SoCuoi) Then
                    StrL = StrL & " " & Right(STemp, 2)
                    bCount = bCount + 1
                End If
                STemp = ""
            End If
        End If
    Next bVTr
    myCell.Offset(, -1) = StrL
    If myCell.Offset(, 1) = "" Then myCell.Offset(, 1) = bCount
27  Next myCell
End Sub

Mã: 
Function NoSelect(SCuoi As Integer) As Boolean
 If SCuoi Mod 10 = 1 Or (SCuoi Mod 10 = (SCuoi \ 10) Mod 10) Then _
    NoSelect = True
End Function
 
@SA_DQ : Bro ơi, Macro thứ 2 & HÀM của bro thì mình RUN được rồi. Chỉ còn là kết quả thì vẫn chưa thể hiện đúng so với Macro thứ 1. Mình có gửi kèm file demo theo dưới đây, bro xem & kiểm tra lại giùm mình nhé ... Thanks !!!
 
Lần chỉnh sửa cuối:
Oh, file hình lớn (dung lượng lớn) quá bạn ơi - mở mãi k ra
bạn nên chuyển định dạng jpg / gif / png và quan trọng là độ phân giải là 72px thui
.

Oh phải save về mới thấy

Bạn copy thiếu hàm NoSelect này rùi, bạn copy thêm vào cuối module nhé là OK

PHP: 
 Function NoSelect(SCuoi As Integer) As Boolean
 If SCuoi Mod 10 = 1 Or (SCuoi Mod 10 = (SCuoi \ 10) Mod 10) Then _
    NoSelect = True
End Function
 
Lần chỉnh sửa cuối:
Anti-Plus đã viết:
@SA_DQ : Bro ơi, cái macro thứ 2 mình RUN bị lỗi rồi ... mình không biết cách khắc phục lỗi rất mong bro giúp mình nữa nhé. (Hiện tại thì macro thứ 1 mình vẫn RUN rất tốt). ---> có hình ảnh minh họa về lỗi ở phía dưới !
Nhấp chuột vào đây để mở rộng...
Cái macro thứ hai, như bạn gọi, không phải là macro để chạy/run đâu! Đó là một hàm mình viết để bổ trợ cho macro trên trong lựa chọn (theo iêu cầu mới phát sinh của bạn) mà thôi;
Bạn chạy cái macro thứ nhất của lần gởi sau trên là được kết quả rồi, còn cần gì thử cái thứ hai (cái hàm NoSelect) chi cho mệt zậy?!
Chú í quan trọng: các ô trái & phải của ô có comments phải không chứa dữ liệu trước khi chạy/run macro!!
Nói cách khác: trước khi muốn thấy kết quả của việc macro thực hiện, các ô trái & phải phải không chứa dữ liệu bất kỳ nào.--=0
 
Lần chỉnh sửa cuối:
Bro ơi, xem lại file demo mình gửi kèm theo đó. Kết quả lọc từ comment chưa được thể hiện đúng & Macro khi Run để lọc từ comment thì kết quả số lẻ của 2 số cuối cùng của hàng cuối cùng luôn luôn không được lọc ra để thể hiện kết quả ở ô B2. Thanks !
 
Lần chỉnh sửa cuối:
Đúng là macro còn thiếu 1 lệnh tại dòng trên dòng có số 27 1 dòng
Hiện là: myCell.Offset(, -1) = StrL
Bạn sửa lại giúp là:
Mã: 
   myCell.Offset(, -1) = StrL:             StrL = ""
Cho mình biết kết quả nha!
 
- Macro đã RUN đúng rồi nhưng vẫn còn thiếu 1 chi tiết nữa là khi Run để lọc từ comment thì kết quả số lẻ của 2 số cuối cùng của hàng cuối cùng luôn luôn không được lọc ra để thể hiện kết quả ở ô B2.

- & ô B2 hiển thị kết quả chưa đúng. Vd theo hình ảnh minh họa bên dưới thì comment của ô C4 có số 2 số lẻ của hàng cuối cùng là 23 thì ô B4 không được lọc ra. (hầu hết các cặp số lẻ được nằm ở hàng cuối cùng đều không được lọc ra)

- Tiếp nữa, là ô D2 dùng để tổng cộng lại các cặp số từ ô B2 thì kết quả vẫn chưa được chính xác lắm. Vd cũng theo hình ảnh minh họa bên dưới thì ô D11 đến ô D16 có tổng cộng những cặp số như sau thì mới đúng kết quả Y/C :

D11 = 9
D12 = 2
D13 = 5
D14 = 7
D15 = 7
D16 = 3

Thanks !

editmacro.jpg
 

File đính kèm

Lần chỉnh sửa cuối:
Anh SA_DQ ơi, giúp mình thêm 1 chút nữa nhé ... Rất mong sớm nhận được tin tức từ anh. Thanks !!!
 
Bạn dùng thử code này.(Viết phỏng theo code của bác SA_DQ)
Mã: 
Option Explicit
Sub DatafromComment()
Dim StrChuoilon As String, StrChuoitim As String, StrKetqua as String
Dim CommCell As Range, CommRng As Range
Dim i As Integer, j As Integer
Dim StrChuoinho As Variant
Set CommRng = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
  On Error Resume Next
   For Each CommCell In CommRng
           StrChuoilon = CommCell.Comment.Text
           StrChuoilon = Replace(StrChuoilon, Chr(10), "-")
           StrChuoinho = Split(StrChuoilon, "-")
               For i = 0 To UBound(StrChuoinho)
                 StrChuoinho(i) = Trim(StrChuoinho(i))
                 StrChuoitim = Right(StrChuoinho(i), 2)
                    If StrChuoitim Mod 2 = 1 Then
                     If Right(StrChuoitim, 1) <> "1" And Right(StrChuoitim, 1) <> Left(StrChuoitim, 1) Then
                       StrKetqua = StrKetqua & " " & StrChuoitim
                       j = j + 1
                     End If
                     End If
                Next
          CommCell.Offset(0, -1) = StrKetqua
          CommCell.Offset(0, 1) = j
          StrKetqua = ""
           j = 0
   Next
End Sub
 

File đính kèm

Anti-Plus đã viết:
Anh SA_DQ ơi, giúp mình thêm 1 chút nữa nhé ... Rất mong sớm nhận được tin tức từ anh. Thanks !!!
Nhấp chuột vào đây để mở rộng...
PHP: 
Option Explicit

Sub CopyCommLeftCell()
 Dim CommRng As Range, myCell As Range
 Dim curWks As Worksheet
 Dim bVTr As Byte, DDai As Byte, bCount As Byte, SoCuoi As Integer
 Dim STemp As String, StrC As String, StrL As String
  
  Application.ScreenUpdating = False
  Set curWks = ActiveSheet:                 On Error Resume Next
  Set CommRng = curWks.Cells.SpecialCells(xlCellTypeComments)
  On Error GoTo 0
  If CommRng Is Nothing Then
     MsgBox "No comments found":                    Exit Sub
  End If
  For Each myCell In CommRng
    StrC = myCell.comment.Text & " ":               DDai = Len(StrC)
    If myCell.Offset(, -1) <> "" Then GoTo 27
    For bVTr = 1 To DDai
        If IsNumeric(Mid(StrC, bVTr, 1)) Then
            STemp = STemp & Mid(StrC, bVTr, 1)
        Else
            If Len(STemp) > 1 Then
                SoCuoi = CInt(Right(STemp, 2))
                If SoCuoi Mod 2 = 1 And Not NoSelect(SoCuoi) Then
                    StrL = StrL & " " & Right(STemp, 2)
                    bCount = bCount + 1
                End If
                STemp = ""
            End If
        End If
    Next bVTr
    myCell.Offset(, -1) = StrL
    If myCell.Offset(, 1) = "" Then myCell.Offset(, 1) = bCount
    bCount = 0
    myCell.Offset(, -1) = StrL:                     StrL = ""
27  Next myCell
End Sub
Mã: 
Function NoSelect(SCuoi As Integer) As Boolean
 If SCuoi Mod 10 = 1 Or (SCuoi Mod 10 = (SCuoi \ 10) Mod 10) Then _
    NoSelect = True
End Function
 
Code của bro SA_DQ đã đúng yêu cầu & kết quả chính xác 100% rồi & đồng thời cũng cám ơn luôn bro voda rất nhiều vì code của bro kết quả cũng đúng Y/C & KQ cũng chính xác 100% giống như pác SA_DQ ... Một lần nữa xin cám ơn bro rất nhiều !
 
Lần chỉnh sửa cuối:
Bro SA_DQ ơi, giúp mình thêm phát nữa nhé.

PHP: 
Option Explicit 
 
Sub CopyCommLeftCell() 
 Dim CommRng As Range, myCell As Range 
 Dim curWks As Worksheet 
 Dim bVTr As Byte, DDai As Byte, bCount As Byte, SoCuoi As Integer 
 Dim STemp As String, StrC As String, StrL As String 
 
  Application.ScreenUpdating = False 
  Set curWks = ActiveSheet:                 On Error Resume Next 
  Set CommRng = curWks.Cells.SpecialCells(xlCellTypeComments) 
  On Error GoTo 0 
  If CommRng Is Nothing Then 
     MsgBox "No comments found":                    Exit Sub 
  End If 
  For Each myCell In CommRng 
    StrC = myCell.comment.Text & " ":               DDai = Len(StrC) 
    If myCell.Offset(, -1) <> "" Then GoTo 27 
    For bVTr = 1 To DDai 
        If IsNumeric(Mid(StrC, bVTr, 1)) Then 
            STemp = STemp & Mid(StrC, bVTr, 1) 
        Else 
            If Len(STemp) > 1 Then 
                SoCuoi = CInt(Right(STemp, 2)) 
                If SoCuoi Mod 2 = 1 And Not NoSelect(SoCuoi) Then 
                    StrL = StrL & " " & Right(STemp, 2) 
                    bCount = bCount + 1 
                End If 
                STemp = "" 
            End If 
        End If 
    Next bVTr 
    myCell.Offset(, -1) = StrL 
    If myCell.Offset(, 1) = "" Then myCell.Offset(, 1) = bCount 
    bCount = 0 
    myCell.Offset(, -1) = StrL:                     StrL = "" 
27  Next myCell 
End Sub  
Function NoSelect(SCuoi As Integer) As Boolean
 If SCuoi Mod 10 = 1 Or (SCuoi Mod 10 = (SCuoi \ 10) Mod 10) Then _
    NoSelect = True
End Function

Cũng từ macro trên & theo hình ảnh minh họa bên dưới thì từ ô D2 đến D8 thì những chuỗi dữ liệu nằm trong đó đang có màu xanh, mình muốn so sánh như sau :

D8 so sánh vơi D7
D7 so sánh với D6
D6 so sánh với D5
D5 so sánh với D4
D4 so sánh với D3
D3 so sánh với D2

Quá trình so sánh giữa các hàng như vậy, nếu có những cặp số trùng nhau thì sẽ tự động thay đổi thành màu đỏ (nghĩa là so sánh từ hàng dưới lên hàng trên).

& từ macro trên khi thực hiện lệnh RUN & phát hiện những ra cặp số lẻ được lọc ra từ ô D2 đến D8 thì trong Comment ta có thể tự động thay đổi luôn những cặp số đó thành mà đỏ luôn có được không (giống như hình ảnh minh họa bên dưới) ?

Mình có kèm theo file demo luôn đó ...

Một lần nữa xin chân thành cám ơn bro rất nhiều vì sự nhiệt tình của bro !

compare_row.jpg
 

File đính kèm

Lần chỉnh sửa cuối:
Anti-Plus đã viết:
Bro SA_DQ ơi, giúp mình thêm phát nữa nhé.
Cũng từ macro trên & theo hình ảnh minh họa bên dưới thì từ ô D2 đến D8 thì những chuỗi dữ liệu nằm trong đó đang có màu xanh, mình muốn so sánh như sau :
D8 so sánh vơi D7
D7 so sánh với D6
D6 so sánh với D5
D5 so sánh với D4
D4 so sánh với D3
D3 so sánh với D2
Quá trình so sánh giữa các hàng như vậy, nếu có những cặp số trùng nhau thì sẽ tự động thay đổi thành màu đỏ (nghĩa là so sánh từ hàng dưới lên hàng trên).
Nhấp chuột vào đây để mở rộng...
Sau trong hình lại tô màu lung tung cả lên vậy;
* Khi so sánh dòng 8 với dòng 7 chỉ có cặp số 45 là giống nhau, sao bạn lại tô cả số 57 & 17 ở dòng 8 là sao?; Mình cho rằng phải chính xác trong thông tin mới làm tiếp được;
 
àh, ô D8 sở dĩ mình tô đỏ 57 & 17 là vì dưới ô D8 vẫn còn tiếp những hàng ở bên dưới nữa ... cái hình đó mình rút gọn lại cho ngắn bớt nên quên bỏ những số đó.

compare_row_fix.jpg
 
Lần chỉnh sửa cuối:
Bro SA_DQ ơi, giúp mình thêm phát nữa nhé.
Nhấp chuột vào đây để mở rộng...
1*/ Bạn đừng nên viết thế này; Mà nên dùng là đại từ ngôi thứ hai số nhiều
Tại sao thì bạn tự tìm hiểu & trả lời, nha!

2*/ Bạn chạy Color2 độc lập sau cái macro hôm trước, hay thêm dòng
Color2 vô trước dòng lệnh cuối để gọi macro2 này
Tuy nhiên Macro1 không thể không cùng song hành với người anh em kết nghĩa của nó
3*/ Trong 2 macro mình chỉ cho rằng có 5 nhóm số trùng nhau là tối đa giữa 2 dòng; Trong thực tế nhiều hơn, bạn nên tăng biến mảng này lên cho phù hợp.

PHP: 
Option Explicit:            Option Base 1

Sub Color2()
 Dim cRng As Range, sRng As Range, Clls As Range
 Dim StrC0 As String, StrC1 As String
 Dim bDD As Byte, bJ As Byte, bVTr As Byte, bDem As Byte
 
 Set cRng = Cells.SpecialCells(xlCellTypeComments)
 Set sRng = cRng.Cells(1, 1).Offset(, -1).Resize(cRng.Rows.Count, 1)
 Application.ScreenUpdating = False
 
 For Each Clls In sRng
    If Clls.Row = 1 Then
        GoTo 35
    Else
        Set cRng = Clls.Offset(-1)
        StrC0 = cRng.Value:                     StrC1 = Clls.Value
        bDD = Len(StrC0):                       ReDim MVTr(5) As Byte
        For bJ = 1 To bDD Step 3
            bVTr = InStr(1, StrC1, Mid(StrC0, bJ + 1, 2))
            If bVTr > 0 Then
                bDem = 1 + bDem:                MVTr(bDem) = bJ + 1
            End If
        Next bJ
        Color1 cRng, MVTr:                      bDem = 0
    End If
35 Next Clls
End Sub
Mã: 
[B]Sub Color1[/B](Rng As Range, MMM As Variant)
 Dim bZ As Byte
 
    Rng.Select
    With ActiveCell.Characters(Start:=1, Length:=MMM(1) - 1).Font
        .ColorIndex = 11
    End With
For bZ = 1 To 5
    If MMM(bZ) = 0 Then Exit For
    With ActiveCell.Characters(Start:=MMM(bZ), Length:=2).Font
        .ColorIndex = 3
    End With
    With ActiveCell.Characters(Start:=MMM(bZ) + 2, Length:=12).Font
        .ColorIndex = 11
    End With
 Next bZ
[B]End Sub[/B]
 
@SA_DQ ơi, xem lại file demo mình gửi kèm theo nhé, mình đã chạy macro rồi mà sao kết quả không như mong muốn theo hình minh họa ở dưới. Thanks !!!

compare_row_fix.jpg
 

File đính kèm

Lần chỉnh sửa cuối:
Ai cha... bài này nhìn vào code của các cao thủ như anh SA mà hiểu dc e rằng hơi bị lâu...
Nếu là tôi thì tôi sẽ dùng phương pháp củ chuối như sau:
1> Đầu tiên dùng code để Export Comment ra cell
PHP: 
Sub Com_Exp()
Set RngCom = Cells.SpecialCells(xlCellTypeComments)
For Each Clls In RngCom
  CM1 = Clls.Comment.Text
  CM = Application.WorksheetFunction.Substitute(CM1, Chr(10), "-")
  Clls.Offset(, -1).Value = CM
Next
End Sub
Ta dc chuổi số có dạng: xxx-yyy-zzz-........
2> Dùng công cụ Text to Column để tách ra từng số 1
3> Cuối cùng dùng các hàm IF, MOD.. vân vân để lấy ra số cần tìm
Dể như ăn cháo!
Cách của anh SA cho kết quả trong vòng.. nháy mắt thì cách củ chuối này tuy ko nhanh nhưng cũng ko chậm gì lắm... Cùng lắm trong vòng 5 phút là ra... Quan trọng nhất là hiểu dc cái mình đang làm là giống gì ... He... he...
ANH TUẤN
 
Xong câu I rồi đây, Xem xét & cho í kiến nha!

PHP: 
Option Explicit:            Option Base 1

Sub ColorInRow()
 Dim cRng As Range, sRng As Range, Clls As Range
 Dim StrC As String, StrC1 As String, StrC9 As String
 Dim bDD As Byte, bJ As Byte, bVTr As Byte, bVTri As Byte
 
 Set cRng = Cells.SpecialCells(xlCellTypeComments)
 Set sRng = cRng.Cells(1, 1).Offset(, -1).Resize(cRng.Rows.Count, 1)
 Application.ScreenUpdating = False:            Set cRng = Nothing
 For Each Clls In sRng
    ReDim MVTr(9) As Byte:                      Dim bDem As Byte
    If Clls = sRng.Cells(1, 1) Or Clls = sRng.Cells(sRng.Rows.Count, 1) Then
        StrC = Clls.Value:                      bDD = Len(StrC)
        If Clls = sRng.Cells(1, 1) Then
            StrC1 = Clls.Offset(1)
        ElseIf Clls.Address = sRng.Cells(sRng.Rows.Count, 1).Address Then
            StrC1 = Clls.Offset(-1)
        End If
        For bJ = 1 To bDD Step 3
            bVTr = InStr(1, StrC1, Mid(StrC, bJ + 1, 2))
            If bVTr > 0 Then
                bDem = 1 + bDem:                MVTr(bDem) = bJ + 1
            End If
        Next bJ
        Color1 Clls, MVTr:                      bDem = 0
    Else
        StrC1 = Clls.Offset(-1).Value:          StrC = Clls.Value
        StrC9 = Clls.Offset(1).Value:           bDD = Len(StrC)
        For bJ = 1 To bDD Step 3
            bVTr = InStr(1, StrC1, Mid(StrC, bJ + 1, 2))
            bVTri = InStr(1, StrC9, Mid(StrC, bJ + 1, 2))
            If bVTr > 0 Or bVTri > 0 Or (bVTr > 0 And bVTri > 0) Then
                bDem = 1 + bDem:                MVTr(bDem) = bJ + 1
            End If
        Next bJ
        Color1 Clls, MVTr:                      bDem = 0
    End If
 Next Clls
End Sub

Mã: 
[B]Sub Color1(Rng As Range, MMM As Variant)[/B]
 Dim bZ As Byte
 
    Rng.Select
    With ActiveCell.Characters(Start:=1, Length:=MMM(1) - 1).Font
        .ColorIndex = 11
    End With
 For bZ = 1 To 9
    If MMM(bZ) = 0 Then Exit For
    With ActiveCell.Characters(Start:=MMM(bZ), Length:=2).Font
        .ColorIndex = 3
    End With
    With ActiveCell.Characters(Start:=MMM(bZ) + 2, Length:=12).Font
        .ColorIndex = 11
    End With
 Next bZ
[B]End Sub[/B]
 
Lần chỉnh sửa cuối:
-Những yêu cầu của bạn Anti-Plusđược bác SA_DQgiải quyết hoàn toàn. Những đoạn code của bác SA_DQ đã cho mình rất nhiều bài học. Tuy nhiên trong quá trình mày mò tìm lời giải, mình cũng viết được một vài đoạn, nếu bỏ đi cũng tiếc nên post lên để các bạn đọc cho vui và để trao đổi học tập. Mong các bạn cho ý kiến.
Mã: 
Option Explicit
Sub color()
Dim StrC1 As Variant, StrC2 As Variant
Dim C1 As Integer, C2 As Integer, i As Integer, j As Integer
Dim MyCell As Range
Range("vungchon").Select
Selection.Font.ColorIndex = 11
For Each MyCell In Selection
StrC1 = Split(MyCell, " ")
   C1 = 1: C2 = 1
     For i = 1 To UBound(StrC1)
        StrC2 = Split(MyCell.Offset(1, 0), " ")
            For j = 1 To UBound(StrC2)
               If StrC1(i) = StrC2(j) Then
                 MyCell.Characters(Start:=C1, Length:=3).Font.ColorIndex = 3
                 MyCell.Offset(1, 0).Characters(Start:=C2, Length:=3).Font.ColorIndex = 3
               End If
               C2 = C2 + 3
            Next
         C2 = 1
        C1 = C1 + 3
     Next
Next
End Sub
 

File đính kèm

Quá dễ hiểu & rất chi rõ ràng & mạch lạc!

Vấn đề còn lại là nhỏ vô cùng; đó là thời lượng hoàn tất chương trinh;
Đối với những CSDL dưới 1.000 dòng thì sẽ chẵng hề hấn gì; nhưng hơn thì có khi của bác sẽ chậm hơn của tôi.
Nếu như CSDL có n dòng thì vòng lặp của bác là 2*n lần; của tôi có thể chỉ là 1.5*n lần mà thôi; Bác thấy tôi dùng hàm InStr() sẽ nhanh hơn vòng lặp thứ 2 của bác (?)

Còn một câu hỏi cuối nữa: tô màu các chữ số cuối trong các Comments; Mình mới thấy lóe đóm lữa nhỏ ở cuối đường hầm mà thôi; Rất mong Bác & các bạn, chúng ta cùng giải quyết rốt ráo vấn đề này

To MOD phụ trách: Có lẽ chuyển Topic này sang macro thôi;
Ngay ÂnhTuân1066 cũng phải dùng macro để tách các chữ số kia từ Comments kia mà! Mình cho rằng nếu muốn giải bằng công thức, chỉ có ý nghĩa học thuật mà thôi; Đối với khả năng về công thức hạn hẹp của mình, giải công thức vấn đề này là không tưởng!
Chờ kết quả & ý kiến của các 'Siêu nhân Công thức' để được chiêm nghiệm sự đẹp đẽ của excel nói chung!
 
Các bro ơi, cái macro thì đã chạy chính xác rồi. Nhưng mình muốn mở rộng thêm vùng chọn để cho macro tự động làm thêm nữa thì phải làm thế nào ?

Mình có kèm theo file demo cho các bro đó ... Xin cám ơn sự giúp đỡ tận tình !

(file mình gửi kèm theo để demo cũng chính xác là file mình đang sử dụng cho nhu cầu riêng của mình luôn đó)
 

File đính kèm

Cái macro thì đã chạy chính xác rồi. Nhưng mình muốn mở rộng thêm vùng chọn để cho macro tự động làm thêm nữa thì phải làm thế nào ? Mình có kèm theo file demo cho các bro đó . . . cũng chính xác là file mình đang sử dụng cho nhu cầu riêng của mình luôn đó)[/I][/B]
Nhấp chuột vào đây để mở rộng...
Với macro LocKQ thì không có vấn đề gì, phải không; Cứ bấm chạy & được kết quả;
Với macro ColorInRow Bạn ghi thêm dòng lệnh này:
Mã: 
 Set cRng = Application.InputBox("Hay Dung Chuot Chon Vung:", Type:=8)
vô sau dòng:
Set cRng = Cells.SpecialCells(xlCellTypeComments);
Khi chạy macro, sẽ xuất hiện hộp thoại bảo bạn chọn vùng cần (tô màu);
Khi đó bạn dùng chuột quét chọn vùng chưa tô màu; Mình ví dụ bạn chọn mỗi lần chạy macro 1 trong các vùng sau:
'E3:E9'
'E13:E19'
'E23:E29'
'E32:E39'
Chịu khó chọn cho đến hết; tại chúng ta chưa lường hết thực tiển của bạn mà!
 
Thank you bro !!! Kết quả thành công mỹ mãn ... Mình rất mong bro sớm hoàn thành câu hỏi 2 càng sớm càng tốt ... Chúc bro 1 ngày vui vẻ & gặt hái được nhiều thành công !
 
Nguyên văn bởi SA_DQ
Quá dễ hiểu & rất chi rõ ràng & mạch lạc!
Nhấp chuột vào đây để mở rộng...
-Cám ơn lời động viên của bác.
Vấn đề còn lại là nhỏ vô cùng; đó là thời lượng hoàn tất chương trinh;
Nhấp chuột vào đây để mở rộng...
-Mình nghĩ vấn đề này không nhỏ. Nhiều khi phải xử lý một CSDL lớn, vài nghìn dòng chẳng hạn, mình gặp rất nhiều khó khăn. Lúc bấy giờ có thể phải thay đổi toàn bộ phương án. Cũng có khi không tìm được cách giải quyết nào. Vẫn phải chấp nhận cho người dùng chờ đợi. Mình đồng ý với bác là nên hạn chế vòng lặp. Nhất là vòng lặp lồng nếu có một cách làm khác.
-Cám ơn bác đã chỉ ra chỗ này.
 
Sao đoạn code này bỏ sót

Trong khi tìm lời giải cho câu cuối còn lại, tôi đã tạo ra macro;
Nội dung nó như dưới đây, Nhưng nó chưa làm đúng í:
* Các số cuối đạt điều kiện cần tô màu trong Comments, thì chưa tô được
* Cái này mới khó hiểu hơn, macro bỏ sót một vài số trong dãy số cần tô màu
(Trong hình đính kèm số 85 & 65 chưa được tô màu.)
Mong các bạn xem xét & chỉ ra cách khắc phục giúp
PHP: 
Sub CommentsFontColorS()
 Dim cRng As Range, sRng As Range, Clls As Range
 Dim StrC As String, sComm As String
 Dim bLen As Byte, bW As Byte, bVTr As Byte

 Set cRng = Cells.SpecialCells(xlCellTypeComments)
 Set sRng = cRng.Cells(1, 1).Offset(, -1).Resize(cRng.Rows.Count, 1)
 For Each Clls In cRng
    StrC = Clls.Offset(, -1):               bLen = Len(StrC)
    sComm = Clls.Comment.Text & " "
    With Clls.Comment.Shape.TextFrame
        For bW = 1 To bLen Step 3
            bVTr = InStr(1, sComm, Mid(StrC, bW + 1, 2))
            If bVTr > 0 And (Mid(sComm, bVTr + 2, 1) = "-" _
                Or Mid(sComm, bVTr + 2, 1) = " ") Then _
                .Characters(Start:=bVTr, Length:=2).Font.ColorIndex = 3
        Next bW

    End With
 Next Clls
Exit Sub:           End Sub


Comment.jpg
 
Đúng là macro của bro đã có phát huy tác dụng, nhưng vẫn còn bỏ sót 1 số thỏa điều kiện mà vẫn chưa được thi hành. Rất mong các bro cùng nhau khắc phục lỗi này nhé .... Thanks !!!
 
Cứ tưởng việc trích xuất chuổi từ trong Comment là độc quyền của VBA, nhưng tôi phát hiện thì ra công thức vẫn có thể làm dc điều này...
Quy trinh thực hiện như sau:



A> Giã thiết rằng trong bảng tính chỉ có comment mà ko có bất cứ object nào khác:
Bước 1: Đặt con trỏ chuột tại cell đầu tiên, nơi mà bạn muốn xuất dử liệu ra.. Tiếp theo vào Define name và đặt các name sau đây:​
Mã: 
Ob_Label =GET.DOCUMENT(42+NOW()*0)
[/INDENT]

[INDENT]Get_Com =GET.OBJECT(12,INDEX(Ob_Label,1,ROWS($1:1)))
Bước 2: Ngay tại vị trí cell ấy, gõ vào công thức:​
Mã: 
=SUBSTITUTE(Get_Com,CHAR(10),"-")
Kéo fill công thức xuống​

B> Trong trường hợp trên bảng tính ngoài comment còn có các object khác thì công việc khó hơn 1 chút:
Bước 1: Đặt con trỏ tại cell đầu tiên mà bạn muốn xuất dử liệu rồi vào Define name và đặt 3 name:​
Mã: 
Ob_Label =GET.DOCUMENT(42+NOW()*0)
[/INDENT][INDENT]Get_Com =GET.OBJECT(12,INDEX(Ob_Label,1,SMALL(VT,ROWS($1:1))))[/INDENT][INDENT]VT =IF(ISERR(SEARCH("Comment",Ob_Label,1)),"",TRANSPOSE(ROW(INDIRECT("1:"&COUNTA(Ob_Label)))))
Bước 2: Gõ vào cell ấy công thức:​
Mã: 
=SUBSTITUTE(Get_Com,CHAR(10),"-")
Kéo fill công thức xuống​
Thế là xong!
Bây giờ phần việc khó nhất đã xong, việc còn lại của các cao thủ là dùng cách gì đó để lấy ra giá trị mình cần... Chuyện này nhỏ như con thỏ nhỉ
He... he...
Xem file nhé!
ANH TUẤN
 

File đính kèm

Lần chỉnh sửa cuối:
Đúng là Bác Tuấn có nhiều cách làm cho công thức trở nên linh hoạt không ngờ
 
Tôi xin nói thêm 1 tí về hàm =GET.DOCUMENT(42)
Hàm này tạo ra 1 mãng ngang với các phần tử là tên của tất cả các object đang tồn tại trong sheet.. Việc sắp xếp các phần tử trong mãng dựa trên tiêu chí object dc vẽ ra trước sẽ sắp trước, object vẽ sau sẽ sắp sau (chứ ko nhóm từng loại vào chung)... Chính vì lẽ đó đã gây khó khăn ko ít cho việc xử lý mãng, tách phần Comment ra riêng!
------------------------
Chúng ta có thể áp dụng hàm này để tìm ra các Object trong sheet 1 cách dể dàng đấy (bất kể object đang ẩn hay hiện)
Mến
ANH TUẤN
 
Lần chỉnh sửa cuối:
Các bạn xem dùm đoạn code đã đạt yêu cầu chưa?
Mã: 
Option Explicit
Sub colorC()
Dim StrC1 As Variant, StrC3 As Variant
Dim C3 As Integer, i As Integer, t As Integer, m As Integer
Dim StrChuoilon As String
Dim MyCell As Range
Range("vungchon").Select
For Each MyCell In Selection
StrChuoilon = MyCell.Offset(0, 1).Comment.Text
StrChuoilon = Replace(StrChuoilon, Chr(10), "-")
MyCell.Offset(0, 1).Comment.Shape.TextFrame.Characters.Font.ColorIndex = 11
     C3 = 1
     StrC1 = Split(MyCell, " ")
     For i = 1 To UBound(StrC1)
             StrC3 = Split(StrChuoilon, "-")
              For t = 0 To UBound(StrC3)
                  m = Len(StrC3(t))
                  StrC3(t) = RTrim(StrC3(t))
                  If StrC1(i) = Right(StrC3(t), 2) Then
                 MyCell.Offset(0, 1).Comment.Shape.TextFrame.Characters(Start:=C3 + Len(StrC3(t)) - 2, Length:=2).Font.ColorIndex = 3
                  End If
               C3 = C3 + m + 1
             Next
            C3 = 1
    Next
Next
End Sub
 

File đính kèm

Cám ơn Voda rất nhiều, kết qua đạt yêu cầu 100% ... Vậy là Voda đã giải quyết xong tất cả các câu hỏi đã đạt ra rồi !

P/S: bro ơi, còn 1 sự cố nhỏ nhờ các bro giải quyết giúp luôn là trường hợp của Voda thì rất OK nhưng chỉ sử dụng được trên 1 Sheet thôi, nếu nhảy qua Sheet khác cũng trường hợp như vậy thì không thực hiện việc thay đổi màu mà chỉ thực hiện được lọc kết quả thôi.

Thanks !
 
Lần chỉnh sửa cuối:
Cứ tưởng việc trích xuất chuổi từ trong Comment là độc quyền của VBA, nhưng tôi phát hiện thì ra công thức vẫn có thể làm dc điều này...
Quy trinh thực hiện như sau:
Nhấp chuột vào đây để mở rộng...

thực ra a làm như vậy là công thức k thuần túy

vì đó là dạng của macro 4 _> đều có thể làm được mọi điều mà VBA - dĩ nhiên là đồng mục đích nhưngchưa chắc đã mạnh bằng

-> khẳng định một điều rằng còn nhiều công thức chưa khám phá

hy vọng GPE có nhìu ng như a tuan sẽ khám phá hết, hi iiiiiiiii
 
- Các bro giải quyết xong vấn đề trên & tiếp tục tìm thêm 1 giải pháp giúp mình nữa nhé các bro,

- Theo hình minh họa dưới & có đính kèm theo file demo thì công việc cần giải quyết như sau :

+ Trong Sheet1, mình có những ô Comment [E2:E39] đã được Insert Comment sẵn sẵng nhưng trong những ô Comment này sẽ được rỗng (không chứa bất kì dữ liệu nào).
+ Trong Sheet2, mình có ô B2:B10 được chứa sẵn dữ liệu.
+ Vậy Y/C đặt ra là từ trong Sheet1 & con trỏ ở bất kì ô Comment nào, các bro dùng giải pháp sao cho tại ngay con trỏ có chứa Comment rỗng sẽ tự động lấy dữ liệu từ ô B2:B10 trong Sheet2 vào ngay Comment rỗng này & chỉ vào duy nhất 1 ô Comment mà vị trí con trỏ đang đứng tại Comment đó.

Thanks !!!

FillCommentSheet1.jpg

FillCommentSheet2.jpg
 

File đính kèm

Lần chỉnh sửa cuối:
Nguyên văn bởi SA_DQ
Sao đoạn code này bỏ sót
Nhấp chuột vào đây để mở rộng...
Theo mình nguyên nhân như sau:
1.Các số trong ô tương ứng với Comment:
17 59 37
2. Các số trong Comment:
Mã: 
                                 76 
                                8[COLOR="Red"]17 [/COLOR]
                            [B]37[/B]72-0054-57[COLOR="red"]59[/COLOR] 
                              2646 
           29892-51358-45642-81744-20084-85237-71366 
                       69140-83216 
                            03994 
                            26532 
                             65434
Nhìn vào ta có thể thấy ngay chính số 37 trong 3772 đã làm cho số 37 trong 85237 bị bỏ qua...
 
SA_DQ đã viết:
PHP: 
.......................................

  Set curWks = ActiveSheet
  On Error Resume Next
  Set CommRng = curWks.Cells.SpecialCells(xlCellTypeComments)
  ....................................
End Sub
Nhấp chuột vào đây để mở rộng...


Cẩn thận với phương thức Cells.SpecialCells bác nhé.

_http://tinyurl.com/6hvakg
_http://support.microsoft.com/kb/832293

Thân!
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

H
Đánh số thứ thự phiếu thu chi (1 người xem)
Trả lời
11
Đọc
141
HangktGTN
H
H
Tìm kiếm thông tin chi tiết trên sheet tổng hợp (2 người xem)
Trả lời
1
Đọc
39
LOGANWover
L
N
  • Question Question
Cho em hỏi về mail merge bằng vba (1 người xem)
Trả lời
3
Đọc
62
Hoàng Tuấn 868
H
B
Sau 1 tháng Mã Lại reset về 1 trở lên (4 người xem)
Trả lời
0
Đọc
21
Bảo_Anh_
B
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
410
Đọc
49K
hamhochoi66
H
T
Xin hỏi về bảng lương (2 người xem)
Trả lời
0
Đọc
31
tuandovn
T
Gà Công Nghệ
Tô màu họ và tên bị trùng từ 2 sheet khác nhau (1 người xem)
Trả lời
6
Đọc
93
Gà Công Nghệ
Gà Công Nghệ
A
  • Question Question
Giải thích giúp mình code giải phóng bộ nhớ từ biến (2 người xem)
Trả lời
20
Đọc
9K
nguyendang95
N
Nguyenkhang2404
giúp đỡ lọc dữ liệu nâng cao
Trả lời
22
Đọc
703
Phan Thế Hiệp
Phan Thế Hiệp
B
Dùng button trên forrm để gọi bàn phím ảo win 10(OSK) (1 người xem)
Trả lời
5
Đọc
111
huhumalu
H
P
VẼ ĐƯỜNG TẦN SUẤT (DTS) TRÊN EXCEL (1 người xem)
Trả lời
8
Đọc
181
ptm0412
ptm0412
P
GOAL SEEK NÂNG CAO TRONG EXCEL
    • Thích
Trả lời
4
Đọc
190
Hoale85
H
B
Gán Phím Tắt Gọi Form (1 người xem)
Trả lời
7
Đọc
90
HeSanbi
HeSanbi
K
Điền giá trị ô thay vì địa chỉ ô
Trả lời
2
Đọc
123
LOGANWover
L
G
Chia sẻ các bạn File vẽ kèo Zamil từ excel (1 người xem)
    • Thích
    • Yêu thích
Trả lời
11
Đọc
901
trqt82
T
T
Xin trợ giúp cách lọc trùng về khoảng thời gian (1 người xem)
Trả lời
10
Đọc
2K
Phan Thế Hiệp
Phan Thế Hiệp
L
Xin hàm trích xuất chuỗi trong ô (2 người xem)
Trả lời
12
Đọc
190
LINH7979
L
H
[Xin giúp đỡ] Tìm thời gian trùng ở nhiều khoảng thời gian khác nhau.
Trả lời
14
Đọc
2K
Phan Thế Hiệp
Phan Thế Hiệp
N
Thuế thu nhập cá nhân
    • Chấp nhận
Trả lời
3
Đọc
263
ngouyen1505
N
D
Lọc các ô có dữ liệu trùng nhau trong một cột. Xin chỉ giúp
Trả lời
7
Đọc
304
Gà Công Nghệ
Gà Công Nghệ
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom