Rút gọn giúp code checkFont! (1 người xem)

[ThuNghi]

Tôi có viết 1 code check font từng ký tự trong 1 cell.
Nhưng như thế thì quá chậm, tôi muốn triển khai sang check ký tự đầu của từ thôi, nếu ký tự đầu thỏa => từ đó thỏa.
Đang lùng bùng giữa hàm instr để thay i.
Nhờ các bạn tư vấn giúp.
Cám ơn.

Sub CheckFont()
Dim i&, s&
Dim myRng As Range
Set myRng = Cells(1, 1)
myRng.Font.ColorIndex = 0
For i = 1 To Len(myRng)
  If Mid(myRng, i, 1) = " " Then GoTo Next_For
  With myRng
    With .Characters(i, 1)
      sFontType = .Font.Name
      If sFontType <> "Arial" Then
        s = s + 1
        .Font.ColorIndex = 3
      End If
    End With
  End With
Next_For:
Next i
Set myRng = Nothing
MsgBox s
End Sub

 

[ndu96081631]

Tôi có viết 1 code check font từng ký tự trong 1 cell.
Nhưng như thế thì quá chậm, tôi muốn triển khai sang check ký tự đầu của từ thôi, nếu ký tự đầu thỏa => từ đó thỏa.

Hỏi lại chổ màu đỏ: Trường hợp ngược lại (tức ký tự đầu không thỏa đ/k) thì làm gì?

 

[ThuNghi]

Hỏi lại chổ màu đỏ: Trường hợp ngược lại (tức ký tự đầu không thỏa đ/k) thì làm gì?

Trước đó đã bỏ tô màu rồi.
Không quan trọng, chỉ cần ký tự đầu khác font là từ đó sẽ tô màu.
Đang thắc mắc cho duyệt nhanh vòng lặp chỉ duyệt ký tự đầu thôi.
Cám ơn NDU!
Nếu dùng code này thì nó chỉ tô màu ký tự đầu và có nhanh hơn chút xíu nhưng chưa tôi ưu.

Sub CheckFont2()
Dim i&, s&, eBlank&
Dim myRng As Range
Set myRng = Cells(2, 1)
myRng.Font.ColorIndex = 0
With myRng
  With .Characters(1, 1)
    sFontType = .Font.Name
    If sFontType <> "Arial" Then
      s = s + 1
      .Font.ColorIndex = 3
    End If
  End With
End With
eBlank = InStrRev(myRng, " ") + 1
For i = 2 To eBlank 'Len(myRng)
  If Mid(myRng, i - 1, 1) = " " Then
    With myRng
      With .Characters(i, 1)
        sFontType = .Font.Name
        If sFontType <> "Arial" Then
          s = s + 1
          .Font.ColorIndex = 3
        End If
      End With
    End With
  End If
Next_For:
Next i
Set myRng = Nothing
MsgBox s
End Sub

 

[concogia]

Nếu chỉ cần tô màu như code ở bài 3 Sub CheckFont2 thì ta chơi em Reg sẽ tóm được các ký tự đứng sau khoảng trắng, vòng lặp chỉ chạy qua có mấy em này, hổng có mỏi cẳng

Public Sub LungTungFont()
    Dim i&, s&
    Dim myRng As Range, Re As Object, ReTim As Object, sFontType, Cll
    Set myRng = Cells(1, 1)
    myRng.Font.ColorIndex = 0
    Set Re = CreateObject("vbscript.regexp")
        With Re
             .Global = True
             .Pattern = "\s\w"
                Set ReTim = Re.Execute(" " & myRng)
       End With
        For Each Cll In ReTim
            With myRng               
                    With .Characters(Cll.firstindex + 1, 1)
                        sFontType = .Font.Name
                        If sFontType <> "Arial" Then
                            s = s + 1
                            .Font.ColorIndex = 3
                        End If
                    End With
            End With
    Next Cll
Set myRng = Nothing
MsgBox s
End Sub

Hihi, lâu quá hổng nhậu với Thu Nghi để còn tiếp tục ....rút ra, đút vào

 

[ThuNghi]

Nếu chỉ cần tô màu như code ở bài 3 Sub CheckFont2 thì ta chơi em Reg sẽ tóm được các ký tự đứng sau khoảng trắng, vòng lặp chỉ chạy qua có mấy em này, hổng có mỏi cẳng

Public Sub LungTungFont()
    Dim i&, s&
    Dim myRng As Range, Re As Object, ReTim As Object, sFontType, Cll
    Set myRng = Cells(1, 1)
    myRng.Font.ColorIndex = 0
    Set Re = CreateObject("vbscript.regexp")
        With Re
             .Global = True
             .Pattern = "\s\w"
                Set ReTim = Re.Execute(" " & myRng)
       End With
        For Each Cll In ReTim
            With myRng               
                    With .Characters(Cll.firstindex + 1, 1)
                        sFontType = .Font.Name
                        If sFontType <> "Arial" Then
                            s = s + 1
                            .Font.ColorIndex = 3
                        End If
                    End With
            End With
    Next Cll
Set myRng = Nothing
MsgBox s
End Sub

Hihi, lâu quá hổng nhậu với Thu Nghi để còn tiếp tục ....rút ra, đút vào

Chậm hơn code bài 3 Bác Cò à.
Chưa biết tại sao.

 

[ndu96081631]

Trước đó đã bỏ tô màu rồi.
Không quan trọng, chỉ cần ký tự đầu khác font là từ đó sẽ tô màu.
Đang thắc mắc cho duyệt nhanh vòng lặp chỉ duyệt ký tự đầu thôi.
Cám ơn NDU!
Nếu dùng code này thì nó chỉ tô màu ký tự đầu và có nhanh hơn chút xíu nhưng chưa tôi ưu.

Sub CheckFont2()
Dim i&, s&, eBlank&
Dim myRng As Range
Set myRng = Cells(2, 1)
myRng.Font.ColorIndex = 0
With myRng
  With .Characters(1, 1)
    sFontType = .Font.Name
    If sFontType <> "Arial" Then
      s = s + 1
      .Font.ColorIndex = 3
    End If
  End With
End With
eBlank = InStrRev(myRng, " ") + 1
For i = 2 To eBlank 'Len(myRng)
  If Mid(myRng, i - 1, 1) = " " Then
    With myRng
      With .Characters(i, 1)
        sFontType = .Font.Name
        If sFontType <> "Arial" Then
          s = s + 1
          .Font.ColorIndex = 3
        End If
      End With
    End With
  End If
Next_For:
Next i
Set myRng = Nothing
MsgBox s
End Sub

Code này có 1 trục trặc nhỏ:
- Ví dụ có chuổi "Nguyen Van Thanh" tại cell A1
- Cell A1 đang thiết lập font Arial
- Trong chuổi trên, có ký tự "N" đầu tiên và ký tự "V" là thuộc font Tahoma
- Sau khi chạy code xong, ra đúng kết quả = 2 nhưng code lại làm cho ký tự "N" đầu tiên đổi sang font Arial mất rồi
- Tức nếu chạy code lần 2, kết quả nhận được sẽ =1

 

[ThuNghi]

Code này có 1 trục trặc nhỏ:
- Ví dụ có chuổi "Nguyen Van Thanh" tại cell A1
- Cell A1 đang thiết lập font Arial
- Trong chuổi trên, có ký tự "N" đầu tiên và ký tự "V" là thuộc font Tahoma
- Sau khi chạy code xong, ra đúng kết quả = 2 nhưng code lại làm cho ký tự "N" đầu tiên đổi sang font Arial mất rồi
- Tức nếu chạy code lần 2, kết quả nhận được sẽ =1

Vẫn OK mà, đâu có dòng nào đổi font đâu, đang làm code cho file word nhưng vận dụng ex để chỉ tìm ký tự đầu.

 

[ndu96081631]

Vẫn OK mà, đâu có dòng nào đổi font đâu, đang làm code cho file word nhưng vận dụng ex để chỉ tìm ký tự đầu.

Cứ làm như tôi nói đi, xong chạy code lần 1 --->Xem kết quả rồi chạy code lần 2 ---> Xem kết quả
Thử xem 2 lần chạy code có cho kết quả giống nhau không?
Kể cả code của anh Cò cũng bị tình trạng này luôn

 

[ndu96081631]

Thêm 1 lỗi kỳ lạ nữa (cả code ThuNghi và anh Cò)
- Ta có chuổi "Nguyen Van Thanh" ở cell A1
- Font của cell A1 là Arial
- Ta quét chọn đoạn "Nguyen Van" và đặt font cho nó là Tahoma
- Xong, chạy code ---> Kết quả = 1
???

 

[concogia]

Thêm 1 lỗi kỳ lạ nữa (cả code ThuNghi và anh Cò)
- Ta có chuổi "Nguyen Van Thanh" ở cell A1
- Font của cell A1 là Arial
- Ta quét chọn đoạn "Nguyen Van" và đặt font cho nó là Tahoma
- Xong, chạy code ---> Kết quả = 1
???

Híc, sao mình vẫn thấy là 2 ma Thầy
Chạy nhiều lần vẫn thế

 

[ndu96081631]

Híc, sao mình vẫn thấy là 2 ma Thầy
Chạy nhiều lần vẫn thế

Anh xem file này thử thế nào nhé
(Trên máy em toàn báo sai kết quả cho lần chạy thứ 2)

 

[concogia]

Anh xem file này thử thế nào nhé
(Trên máy em toàn báo sai kết quả cho lần chạy thứ 2)

Híc, sao vậy Trời
Trong A1 có thằng "v" là Font Tahoma thì code báo 1, bấm bi nhiêu lần nó vẫn báo 1
Mình sửa "thanh" sang Tahoma, bấm....mỏi tay nó vẫn báo 2 mà Trời
Hôm nay.....khó hiểu quá
Híc

 

[ndu96081631]

Híc, sao vậy Trời
Trong A1 có thằng "v" là Font Tahoma
Híc

Ngoài thằng "v" là Tahoma còn có thằng "N" đầu tiên cũng là Tahoma đó anh!
------------
Kiểm tra: Nếu trong code ta bỏ đi dòng ....Font.ColorIndex = 3 thì sẽ không có vấn đề gì cả
Tạm kết luận: Có thể việc set Font.ColorIndex đã làm thay đổi 1 số thuộc tính của Range chăng?

 

[ThuNghi]

Ngoài thằng "v" là Tahoma còn có thằng "N" đầu tiên cũng là Tahoma đó anh!
------------
Kiểm tra: Nếu trong code ta bỏ đi dòng ....Font.ColorIndex = 3 thì sẽ không có vấn đề gì cả
Tạm kết luận: Có thể việc set Font.ColorIndex đã làm thay đổi 1 số thuộc tính của Range chăng?

Vậy nhờ NDU viết giúp thuật toán for i từ blank này sang blank khác thôi.
Rút gọn bớt vòng lặp ngoài cách Bác Cò.

 

[le tin]

Bạn kiểm tra giúp đọan này xem sao:
Dim i&, s&, tmp, Chu, j
Dim myRng As Range
Set myRng = Cells(1, 1)
myRng.Font.ColorIndex = 0
tmp = Split(myRng, " ")
For i = 0 To UBound(tmp)
If tmp(i) <> "" Then
Chu = Chu & " " & tmp(i)
With myRng
With .Characters(j + 1, 1)
sFontType = .Font.Name
If sFontType <> "Arial" Then
s = s + 1
myRng.Characters(j + 1, Len(tmp(i))).Font.ColorIndex = 3
End If
End With
End With
End If
j = Len(Chu)
Next i
Set myRng = Nothing
MsgBox s

 

[ndu96081631]

Vậy nhờ NDU viết giúp thuật toán for i từ blank này sang blank khác thôi.
Rút gọn bớt vòng lặp ngoài cách Bác Cò.

Cũng dễ thôi mà:

Function CheckFontName(ByVal rCel As Range, ByVal FontName As String) As Long
  Dim tmp As String, fnt As Font, i As Long, n As Long
  On Error Resume Next
  tmp = rCel.Text & " "
  i = 1
  Do
    Set fnt = rCel.Characters(i, 1).Font
    If fnt.Name <> FontName Then
      n = n + 1
      ''Muon lam gi them thi viet vao day
    End If
    i = InStr(i, tmp, " ") + 1
  Loop Until i >= Len(tmp)
  CheckFontName = n
End Function