[Giúp] Sửa code VBA check số điện thoại di động

Liên hệ QC
R

robinhsoon

Thành viên hoạt động
Tham gia
19/1/16
Bài viết
153
Được thích
11
Chào cả nhà GPEX!

Em có một đoạn code:

Sub Handphone_Click()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
If Len(sCell.FormulaR1C1) = 10 Or Len(sCell.FormulaR1C1) = 11 Then
If Application.WorksheetFunction.CountIf(Sheet1.[A3:B100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 7)) = 0 Then sCell.Interior.Color = 65535
Else
sCell.Interior.Color = 65535
End If
Next sCell
Else
MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
công việc:
1.Tại Sheet (Data): Kiểm tra độ dài của các số điện thoại ở cột Hand Phone, nếu là độ dài bằng 10 hoặc 11 số (đúng) thì kiểm tra lần lượt các đầu số điện thoại đã khai báo trong thư viện Sheet (Link Erro) (10 số thì kiểm tra cột đã khai báo 10 số và 11 số thì kiểm tra cột 11 số) nếu trùng với các đầu số thì đúng và ngược lại nếu sai thì Highline vàng các số điện thoại lên..

không biết đoạn code sai ở đâu, lúc chạy thì các các đầu số ở cột 11 số là 10 số nhưng vẫn không higline vàng và số 0868 đã khai báo là đúng mà vẫn higline...

Mong các Thầy giúp đỡ ạ.!
 

File đính kèm

  • Check Data CenTral_2017.xlsm
    50.1 KB · Đọc: 12
Sắp xếp theo thời gian sắp xếp theo bầu chọn
10 số có 2 dạng xét 3 số và xét 4 số, bạn phải xét riêng 11 số và 10 số không gộp chung được
 
Upvote 0
robinhsoon đã viết:
Chào Thầy!
Vậy em muốn code cho đúng thì làm sao ạ..
Mong thầy giúp đỡ
Nhấp chuột vào đây để mở rộng...
xét thêm điều kiện 10 số với 4 số đầu
Mã: 
Sub Handphone_Click()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
    For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
        If Len(sCell.FormulaR1C1) = 10 Or Len(sCell.FormulaR1C1) = 11 Then
          If Application.WorksheetFunction.CountIf(Sheet1.[A3:B100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 7)) = 0 _
          And Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 6)) = 0 Then sCell.Interior.Color = 65535
         Else
               sCell.Interior.Color = 65535
         End If
    Next sCell
Else
    MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
 
Upvote 0
HieuCD đã viết:
xét thêm điều kiện 10 số với 4 số đầu
Mã: 
Sub Handphone_Click()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
    For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
        If Len(sCell.FormulaR1C1) = 10 Or Len(sCell.FormulaR1C1) = 11 Then
          If Application.WorksheetFunction.CountIf(Sheet1.[A3:B100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 7)) = 0 _
          And Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 6)) = 0 Then sCell.Interior.Color = 65535
         Else
               sCell.Interior.Color = 65535
         End If
    Next sCell
Else
    MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Chào Thầy,
em đã test đoạn code trên thì nó bị lỗi ngược lại ạ, các điều kiện 10 số của 4 số đầu thì nó higline vàng ok, nhưng điều kiện 10 số với 3 số đầu thì nó bắt sai ạ
 

File đính kèm

  • Check Data CenTral_2017.xlsm
    48.6 KB · Đọc: 2
Upvote 0
robinhsoon đã viết:
Chào Thầy,
em đã test đoạn code trên thì nó bị lỗi ngược lại ạ, các điều kiện 10 số của 4 số đầu thì nó higline vàng ok, nhưng điều kiện 10 số với 3 số đầu thì nó bắt sai ạ
Nhấp chuột vào đây để mở rộng...
bạn chỉnh code mình gởi rồi
Mã: 
If Application.WorksheetFunction.CountIf(Sheet1.[A3:B100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 7)) = 0 _
          And Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 6)) = 0 Then sCell.Interior.Color = 65535
thằng đầu là Sheet1.[A3:B100] chứ không phải là Sheet1.[B3:B100]
 
Upvote 0
HieuCD đã viết:
bạn chỉnh code mình gởi rồi
Mã: 
If Application.WorksheetFunction.CountIf(Sheet1.[A3:B100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 7)) = 0 _
          And Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, Len(sCell.FormulaR1C1) - 6)) = 0 Then sCell.Interior.Color = 65535
thằng đầu là Sheet1.[A3:B100] chứ không phải là Sheet1.[B3:B100]
Nhấp chuột vào đây để mở rộng...
Thưa Thầy!
Em vẫn làm theo code cũ của Thầy nhưng ngay chỗ đầu số 0868 em khai báo bên cột 10 số nhưng lúc em tăng lên 11 số thì vẫn không tô vàng ạ
 

File đính kèm

  • Check Data CenTral_2017.xlsm
    48.5 KB · Đọc: 3
Upvote 0
Chỉ có 4 đầu số tức là 10000 số. Dùng mảng chỉ số để duyệt mới nhanh.
Lâppj 2 mảng, mỗi mảng 10000 số tượng trưng cho 4 số đầu. Cứ thế mà duyệt
code:
' lkup1 là range chứa 3-4 số đầu cho hạng 10; lkup2 là range chứa 4 số đầu cho hạng 11
dim lkup(1 to 2, 1 to 10000) as integer
for each rg in lkup1
lkup(1, Cint(rg.value)) = 1
next rg
for each rg in lkup2
lkup(2, Cint(rg.value)) = 1
next rg
' xét đầu số:
HighlightCells rangesodienthoai, true ' reset range
for each rg in rangesodienthoai
sodienthoai = cstr(rg.formular1c1)
select case len(sodienthoai)
case 10
if lkup(1, cint(left(sodienthoai,4)) = 0 then
if lkup(1, cint(left(sodienthoai,3)) = 0 then HghlightCells rg
end if
case 11
if lkup(2, cint(left(sodienthoai,4)) = 0 then HghlightCells rg
case else
HighLightCells rg
end select
next rg

Sub HighLightCells(rg as range, optional rst as boolean = false)
rg.Interior.Color = IIF(rst, xlNone, 65535)
End Sub
 
Upvote 0
robinhsoon đã viết:
Thưa Thầy!
Em vẫn làm theo code cũ của Thầy nhưng ngay chỗ đầu số 0868 em khai báo bên cột 10 số nhưng lúc em tăng lên 11 số thì vẫn không tô vàng ạ
Nhấp chuột vào đây để mở rộng...
tính gộp lại nhưng không được đành tách 11 số và 10 riêng
lập các lệnh if chi tiết để bạn dể theo dõi
Mã: 
Sub Handphone_Click()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
    Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
    For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
        If Len(sCell.FormulaR1C1) = 11 Then
          If Application.WorksheetFunction.CountIf(Sheet1.[B3:B100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
        Else
          If Len(sCell.FormulaR1C1) = 10 Then
            If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 3)) = 0 Then
              If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
            End If
          Else
            sCell.Interior.Color = 65535
          End If
        End If
    Next sCell
Else
    MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
 
Upvote 0
Người có kinh nghiệm lập trình thường tách rời code mẫu mã ra khỏi code tính toán.
Code mẫu mã ở riêng sẽ dễ kiểm soát và sửa chữa. Ví dụ tôi muốn đổi highhlight từ màu vàng sang màu đỏ và thêm phần tô đậm thì tôi chỉ phải sửa 1 chỗ.
 
Upvote 0
HieuCD đã viết:
tính gộp lại nhưng không được đành tách 11 số và 10 riêng
lập các lệnh if chi tiết để bạn dể theo dõi
Mã: 
Sub Handphone_Click()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
    Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
    For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
        If Len(sCell.FormulaR1C1) = 11 Then
          If Application.WorksheetFunction.CountIf(Sheet1.[B3:B100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
        Else
          If Len(sCell.FormulaR1C1) = 10 Then
            If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 3)) = 0 Then
              If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
            End If
          Else
            sCell.Interior.Color = 65535
          End If
        End If
    Next sCell
Else
    MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn Thầy ạ!
Code của Thầy em chạy ok lắm ạ.. cho em hỏi thêm nếu em muốn những ô bị blank không tô màu thì em thêm đoạn code chỗ nào ạ...
Cảm ơn Thầy nhiều ạ!
 
Upvote 0
VetMini đã viết:
Chỉ có 4 đầu số tức là 10000 số. Dùng mảng chỉ số để duyệt mới nhanh.
Lâppj 2 mảng, mỗi mảng 10000 số tượng trưng cho 4 số đầu. Cứ thế mà duyệt
code:
' lkup1 là range chứa 3-4 số đầu cho hạng 10; lkup2 là range chứa 4 số đầu cho hạng 11
dim lkup(1 to 2, 1 to 10000) as integer
for each rg in lkup1
lkup(1, Cint(rg.value)) = 1
next rg
for each rg in lkup2
lkup(2, Cint(rg.value)) = 1
next rg
' xét đầu số:
HighlightCells rangesodienthoai, true ' reset range
for each rg in rangesodienthoai
sodienthoai = cstr(rg.formular1c1)
select case len(sodienthoai)
case 10
if lkup(1, cint(left(sodienthoai,4)) = 0 then
if lkup(1, cint(left(sodienthoai,3)) = 0 then HghlightCells rg
end if
case 11
if lkup(2, cint(left(sodienthoai,4)) = 0 then HghlightCells rg
case else
HighLightCells rg
end select
next rg

Sub HighLightCells(rg as range, optional rst as boolean = false)
rg.Interior.Color = IIF(rst, xlNone, 65535)
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn Thầy đã giúp đỡ..! em sẽ tham khảo thêm code này ạ
 
Upvote 0
Bài này có thể dùng CF để giải quyết chưa cần đến VBA mà bạn
Công thức cho Conditional formating:
Mã: 
=IF(LEN(HZ3)=10,COUNT(MATCH(IF('link Erro'!$A$3:$A$23="","",'link Erro'!$A$3:$A$23&"*"),Data!HZ3,0))=1,COUNT(MATCH(IF('link Erro'!$B$3:$B$23="","",'link Erro'!$B$3:$B$23&"*"),Data!HZ3,0))=1)
 
Upvote 0
robinhsoon đã viết:
Em cảm ơn Thầy ạ!
Code của Thầy em chạy ok lắm ạ.. cho em hỏi thêm nếu em muốn những ô bị blank không tô màu thì em thêm đoạn code chỗ nào ạ...
Cảm ơn Thầy nhiều ạ!
Nhấp chuột vào đây để mở rộng...
chỉnh lại lệnh
Mã: 
If sCell.Value <> "" Then sCell.Interior.Color = 65535
Mã: 
Sub Handphone_Click1()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
    Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
    For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
        If Len(sCell.FormulaR1C1) = 11 Then
          If Application.WorksheetFunction.CountIf(Sheet1.[B3:B100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
        Else
          If Len(sCell.FormulaR1C1) = 10 Then
            If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 3)) = 0 Then
              If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
            End If
          Else
            If sCell.Value <> "" Then sCell.Interior.Color = 65535
          End If
        End If
    Next sCell
Else
    MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
 
Upvote 0
HieuCD đã viết:
chỉnh lại lệnh
Mã: 
If sCell.Value <> "" Then sCell.Interior.Color = 65535
Mã: 
Sub Handphone_Click1()
Dim sCell As Range, cSeach As Range
Set cSeach = Sheet5.Cells.Find("Q49_2_R3_So dien thoai di dong")
If Not cSeach Is Nothing Then
    Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp)).Interior.Pattern = xlNone
    For Each sCell In Sheet5.Range(cSeach.Offset(1).Address, Sheet5.Range(cSeach.Offset(65000).Address).End(xlUp))
        If Len(sCell.FormulaR1C1) = 11 Then
          If Application.WorksheetFunction.CountIf(Sheet1.[B3:B100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
        Else
          If Len(sCell.FormulaR1C1) = 10 Then
            If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 3)) = 0 Then
              If Application.WorksheetFunction.CountIf(Sheet1.[A3:A100], Left(sCell.FormulaR1C1, 4)) = 0 Then sCell.Interior.Color = 65535
            End If
          Else
            If sCell.Value <> "" Then sCell.Interior.Color = 65535
          End If
        End If
    Next sCell
Else
    MsgBox "xin loi khong tim thay cot Handphone"
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn Thầy đã giúp đỡ em ạ.. Chúc Thầy Thành Công và Sức khỏe ạ..
 
Upvote 0
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

longhungvnpost
kết hợp hàm vlookup và hlookup như thế nào, giúp e với
Trả lời
4
Đọc
52
longhungvnpost
longhungvnpost
Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
2
Trả lời
29
Đọc
490
Emyeuexcel
Emyeuexcel
TrinhThiHai_Kt
  • Dán lên cao
Các câu hỏi về sử dụng diễn đàn
5 6 7
Trả lời
122
Đọc
185K
Hai Lúa Miền Tây
Hai Lúa Miền Tây
8
  • Question
Xin giúp: Nhóm (group data) các dòng trong bảng tính
Trả lời
9
Đọc
332
843824
8
pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
5
Đọc
177
AutoReply
AutoReply
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom