Cần hỗ trợ cách xác định 1 đoạn text có hay không các cụm từ cho trước

Liên hệ QC
T

tangoctuan

Thành viên hoạt động
Tham gia
22/4/08
Bài viết
153
Được thích
19
Nhờ mọi người giúp mình cách làm sao để xác định được trong 1 đoạn text có hay không có 1 từ/cụm từ cho trước (dữ liệu về từ/cụm từ này có thể thay đổi tùy biến)?
File ví dụ (hiện đang làm tay) như trong đính kèm.
Cám ơn cả nhà rất nhiều!
 

File đính kèm

tangoctuan đã viết:
Nhờ mọi người giúp mình cách làm sao để xác định được trong 1 đoạn text có hay không có 1 từ/cụm từ cho trước (dữ liệu về từ/cụm từ này có thể thay đổi tùy biến)?
File ví dụ (hiện đang làm tay) như trong đính kèm.
Cám ơn cả nhà rất nhiều!
Nhấp chuột vào đây để mở rộng...
Dùng Sub VBA, nhấn mặt cười chạy code
Mã: 
Private aBoDau(1 To 65535) As Long
Sub CheckCumTu()
  Dim sArr(), Res() As Long, S
  Dim eRow&, sRow&, i&, j&, n&, Str$
  With Sheet1
    Str = LCase(.Range("F1").Value)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If Len(Str) = 0 Or eRow < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    S = Split(";" & BoDauViet(Str), ";")
    sArr = .Range("B2:B" & eRow + 1).Value
  End With
  n = UBound(S)
  For j = 1 To n
    S(j) = " " & Application.Trim(S(j)) & " "
  Next j
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    Str = " " & BoDauViet(LCase(sArr(i, 1))) & " "
    For j = 1 To n
      If InStr(1, Str, S(j)) Then
        Res(i, 1) = 1
        Exit For
      End If
    Next j
  Next i
  Sheet1.Range("C2").Resize(sRow) = Res
End Sub

Private Function BoDauViet(ByVal Str$) As String
  Dim i&, C$
  If aBoDau(225) <> 97 Then
    CodeKt = Array(97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 105, 105, 105, 105, 105, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 121, 121, 121, 121, 121, 100)
    CodeDau = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, 7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273)
    For i = 0 To UBound(CodeKt)
      aBoDau(CodeDau(i)) = CodeKt(i)
    Next i
  End If
  For i = 1 To Len(Str)
    C = Mid(Str, i, 1)
    If aBoDau(AscW(LCase(C))) Then
      If C = LCase(C) Then Mid(Str, i, 1) = ChrW(aBoDau(AscW(C))) Else Mid(Str, i, 1) = UCase(ChrW(aBoDau(AscW(LCase(C)))))
    End If
  Next i
  BoDauViet = Str
End Function
 

File đính kèm

Hàm tìm chuỗi đại khái như vầy:

Function TimChuoi(ByVal cTim As String, ByVal cTrong As String) As Integer
' hàm xét cụm từ cTim (nhiều cụm) trong chuỗi cTrong
Dim rx As Object
Dim pat As String
Set rx = CreateObject("vbscript.regexp")
rx.Global = True
rx.IgnoreCase = True
rx.Pattern = " *; *"
rx.Pattern = rx.Replace(cTim, "|") ' đổi ; thành | (tức là chọn lựa cụm từ)
TimChuoi = -rx.test(cTrong)
End Function

Loại bỏ dấu (để so sánh) ở bài trên đã có hàm rồi, không lặp lại.
 
HieuCD đã viết:
Dùng Sub VBA, nhấn mặt cười chạy code
Mã: 
Private aBoDau(1 To 65535) As Long
Sub CheckCumTu()
  Dim sArr(), Res() As Long, S
  Dim eRow&, sRow&, i&, j&, n&, Str$
  With Sheet1
    Str = LCase(.Range("F1").Value)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If Len(Str) = 0 Or eRow < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    S = Split(";" & BoDauViet(Str), ";")
    sArr = .Range("B2:B" & eRow + 1).Value
  End With
  n = UBound(S)
  For j = 1 To n
    S(j) = " " & Application.Trim(S(j)) & " "
  Next j
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    Str = " " & BoDauViet(LCase(sArr(i, 1))) & " "
    For j = 1 To n
      If InStr(1, Str, S(j)) Then
        Res(i, 1) = 1
        Exit For
      End If
    Next j
  Next i
  Sheet1.Range("C2").Resize(sRow) = Res
End Sub

Private Function BoDauViet(ByVal Str$) As String
  Dim i&, C$
  If aBoDau(225) <> 97 Then
    CodeKt = Array(97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 105, 105, 105, 105, 105, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 121, 121, 121, 121, 121, 100)
    CodeDau = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, 7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273)
    For i = 0 To UBound(CodeKt)
      aBoDau(CodeDau(i)) = CodeKt(i)
    Next i
  End If
  For i = 1 To Len(Str)
    C = Mid(Str, i, 1)
    If aBoDau(AscW(LCase(C))) Then
      If C = LCase(C) Then Mid(Str, i, 1) = ChrW(aBoDau(AscW(C))) Else Mid(Str, i, 1) = UCase(ChrW(aBoDau(AscW(LCase(C)))))
    End If
  Next i
  BoDauViet = Str
End Function
Nhấp chuột vào đây để mở rộng...
Nhờ xem hộ giúp mình lại chỗ này với, có các cụm từ này mà kết quả trả về = 0.
Untitled.png
Bài đã được tự động gộp:

Mình hiểu vì sao rồi. Hình như code đang bắt cả dấu "." kia đặt sát thì cũng khiến cụm từ đó không được tính luôn. Nhờ bạn chỉnh giúp hộ trường hợp nếu là ký tự chữ cái/số/từ /cụm từ đặt sát thì mới ko tính có cụm từ đó, còn nếu là dấu câu đặt sát trước/sau (, ; . ! ?...) thì cụm từ đó vẫn tính đúng như bình thường.
Cảm ơn bạn.
 
Lần chỉnh sửa cuối:
Vấn đề chỉ là xác định giới hạn của một từ.
Néu code đã có thể biết dấu cách là giới hạn từ rồi thỉ chỉ cần thêm một công việc đổi tất cả các dấu chấm câu thành "dấu cách" + "dấu chấm câu" là được.
 
VetMini đã viết:
Vấn đề chỉ là xác định giới hạn của một từ.
Néu code đã có thể biết dấu cách là giới hạn từ rồi thỉ chỉ cần thêm một công việc đổi tất cả các dấu chấm câu thành "dấu cách" + "dấu chấm câu" là được.
Nhấp chuột vào đây để mở rộng...
Ý tưởng hay quá, tks bạn.
 
tangoctuan đã viết:
Nhờ xem hộ giúp mình lại chỗ này với, có các cụm từ này mà kết quả trả về = 0.
View attachment 226771
Bài đã được tự động gộp:

Mình hiểu vì sao rồi. Hình như code đang bắt cả dấu "." kia đặt sát thì cũng khiến cụm từ đó không được tính luôn. Nhờ bạn chỉnh giúp hộ trường hợp nếu là ký tự chữ cái/số/từ /cụm từ đặt sát thì mới ko tính có cụm từ đó, còn nếu là dấu câu đặt sát trước/sau (, ; . ! ?...) thì cụm từ đó vẫn tính đúng như bình thường.
Cảm ơn bạn.
Nhấp chuột vào đây để mở rộng...
Bạn tự thêm ký tự đặc biệt vào Function
Mã: 
Private aBoDau(1 To 10000) As Long

Sub CheckCumTu()
  Dim sArr(), Res() As Long, S
  Dim eRow&, sRow&, i&, j&, n&, Str$
  With Sheet1
    Str = LCase(.Range("F1").Value)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If Len(Str) = 0 Or eRow < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    S = Split(";" & BoDauViet(Str), ";")
    sArr = .Range("B2:B" & eRow + 1).Value
  End With
  n = UBound(S)
  For j = 1 To n
    S(j) = " " & Application.Trim(S(j)) & " "
  Next j
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    Str = " " & BoDauViet(LCase(sArr(i, 1))) & " "
    Str = BoKyTuDacBiet(Str)
    For j = 1 To n
      If InStr(1, Str, S(j)) Then
        Res(i, 1) = 1
        Exit For
      End If
    Next j
  Next i
  Sheet1.Range("C2").Resize(sRow) = Res
End Sub

Private Function BoDauViet(ByVal Str$) As String
  Dim i&, C$
  If aBoDau(225) <> 97 Then
    CodeKt = Array(97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 105, 105, 105, 105, 105, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 121, 121, 121, 121, 121, 100)
    CodeDau = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, 7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273)
    For i = 0 To UBound(CodeKt)
      aBoDau(CodeDau(i)) = CodeKt(i)
    Next i
  End If
  For i = 1 To Len(Str)
    C = Mid(Str, i, 1)
    If aBoDau(AscW(LCase(C))) Then
      If C = LCase(C) Then Mid(Str, i, 1) = ChrW(aBoDau(AscW(C))) Else Mid(Str, i, 1) = UCase(ChrW(aBoDau(AscW(LCase(C)))))
    End If
  Next i
  BoDauViet = Str
End Function

Private Function BoKyTuDacBiet(ByVal Str$) As String
  Dim i&, sCol&, KyTu$, C$
  KyTu = ",;.:!?"  'Tu them ky tu dac biet vao trong cap nhay kep
  If InStr(1, Str, Chr(10)) Then Str = Replace(Str, Chr(10), " ")
  sCol = Len(KyTu)
  For i = 1 To sCol
    C = Mid(KyTu, i, 1) & " "
    If InStr(1, Str, C) Then
      Str = Replace(Str, C, " ")
    End If
  Next i
  BoKyTuDacBiet = Str
End Function
 
HieuCD đã viết:
Bạn tự thêm ký tự đặc biệt vào Function
Mã: 
Private aBoDau(1 To 10000) As Long

Sub CheckCumTu()
  Dim sArr(), Res() As Long, S
  Dim eRow&, sRow&, i&, j&, n&, Str$
  With Sheet1
    Str = LCase(.Range("F1").Value)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If Len(Str) = 0 Or eRow < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    S = Split(";" & BoDauViet(Str), ";")
    sArr = .Range("B2:B" & eRow + 1).Value
  End With
  n = UBound(S)
  For j = 1 To n
    S(j) = " " & Application.Trim(S(j)) & " "
  Next j
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    Str = " " & BoDauViet(LCase(sArr(i, 1))) & " "
    Str = BoKyTuDacBiet(Str)
    For j = 1 To n
      If InStr(1, Str, S(j)) Then
        Res(i, 1) = 1
        Exit For
      End If
    Next j
  Next i
  Sheet1.Range("C2").Resize(sRow) = Res
End Sub

Private Function BoDauViet(ByVal Str$) As String
  Dim i&, C$
  If aBoDau(225) <> 97 Then
    CodeKt = Array(97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 101, 105, 105, 105, 105, 105, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 121, 121, 121, 121, 121, 100)
    CodeDau = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, 7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273)
    For i = 0 To UBound(CodeKt)
      aBoDau(CodeDau(i)) = CodeKt(i)
    Next i
  End If
  For i = 1 To Len(Str)
    C = Mid(Str, i, 1)
    If aBoDau(AscW(LCase(C))) Then
      If C = LCase(C) Then Mid(Str, i, 1) = ChrW(aBoDau(AscW(C))) Else Mid(Str, i, 1) = UCase(ChrW(aBoDau(AscW(LCase(C)))))
    End If
  Next i
  BoDauViet = Str
End Function

Private Function BoKyTuDacBiet(ByVal Str$) As String
  Dim i&, sCol&, KyTu$, C$
  KyTu = ",;.:!?"  'Tu them ky tu dac biet vao trong cap nhay kep
  If InStr(1, Str, Chr(10)) Then Str = Replace(Str, Chr(10), " ")
  sCol = Len(KyTu)
  For i = 1 To sCol
    C = Mid(KyTu, i, 1) & " "
    If InStr(1, Str, C) Then
      Str = Replace(Str, C, " ")
    End If
  Next i
  BoKyTuDacBiet = Str
End Function
Nhấp chuột vào đây để mở rộng...
Cách của bạn trên cũng giải quyết được về mặt kết quả rồi nhưng lại tác động vào nguồn dữ liệu gốc. Cách này của bạn Hiếu thì hoạt động độc lập và hoàn hảo luôn.
Cám ơn cả nhà!
 
Tôi mách cho bạn đường hướng giải quyết chứ không giải quyết giùm cho bạn.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

minhquipk
  • Question Question
Cách nhận biết những ô đã bị thay đổi giá trị khi thay đổi giá trị dữ liệu ở những ô khác
Trả lời
1
Đọc
13
HeSanbi
HeSanbi
HeSanbi
  • Đã giải quyết
LocalizeXL v1.72 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
62
Đọc
10K
HeSanbi
HeSanbi
H
Tìm kết quả trả về theo loại
Trả lời
9
Đọc
62
VetMini
V
LongHoang123
  • Question Question
Xin hướng dẫn: Cách tạo vùng in dựa trên dữ liệu của listbox bằng VBA!!!
Trả lời
4
Đọc
70
LongHoang123
LongHoang123
V
  • Question Question
Tách số liệu từ bảng tính ngang theo điều kiện
Trả lời
7
Đọc
183
HieuCD
H
M
  • Question Question
"thủ tục để xóa dòng trống " trong Lập trình VBA trong Excel
2 3 4
Trả lời
63
Đọc
15K
SonBDND
S
Q
Hỏi về công thức dò giá
Trả lời
6
Đọc
169
thanthanhan0801
T
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
6
Đọc
322
nguyenhuong34
nguyenhuong34
ThanhPhongDN
hỏi về cách thay đổi giá trị một ô sau khi nhập một giá trị vào đó
Trả lời
7
Đọc
132
vietduc147258
V
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
34
Đọc
13K
hungbon7890
hungbon7890
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
0
Đọc
28
phambahoang
P
A
  • Question Question
code vba chuyển chuỗi thành text
Trả lời
11
Đọc
2K
SonBDND
S
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
11
Đọc
300
HUONGHCKT
H
Tandattb
Xin cách Khắc phục lỗi "Path/File access error"
Trả lời
8
Đọc
282
Tandattb
Tandattb
ThanhPhongDN
Nhờ giúp đỡ về công thức trong google sheet
    • Cười
Trả lời
4
Đọc
82
thuytrangbp28
T
saobekhonglac
Tạo form vòng quay may mắn
    • Thích
2
Trả lời
35
Đọc
15K
VetMini
V
D
Thống kê dữ liệu theo điều kiện
Trả lời
5
Đọc
135
VetMini
V
noisy
Xin file tính chế độ chuyên cần
    • Cười
Trả lời
0
Đọc
39
noisy
noisy
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Cảm ơn
Trả lời
3
Đọc
714
hvnhpro
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
2
Đọc
118
leonguyenz
leonguyenz
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom