Giúp sửa code lọc vba (1 người xem)

minhtuan55 · 8/3/17

Chào cả nhà GPE !
em đang tự học về Code Mãng Array , em cũng tự Viết 1 đoạn code lọc, code lọc thì ok, nhưng em muốn code không phân biệt chữ HOA và Chữ thường thì phải sửa lại làm sao. mong mọi người giúp em

Mã:

Sub LOC()
On Error Resume Next
Dim sArr(), dArr(), Dk1 As String, Dk2 As Long, I As Long, K As Long, R As Long, Col As Long
Dk1 = Range("H4"): Dk2 = Range("I4") ' DIEU KIEN TU CHO
sArr = Range("B4:D15000").Value ' DU LIEU DAU VAO
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 3) ' 3 COT
For I = 1 To R
    If sArr(I, 1) = Dk1 And sArr(I, 2) = Dk2 Then ' DIEU KIEN TUY CHINH
        K = K + 1
        For Col = 1 To 3 ' 3 COT
            dArr(K, Col) = sArr(I, Col)
        Next Col
    End If
Next I
' OUTPUT
Range("L4").Resize(R, 3).ClearContents ' 3 COT
Range("L4").Resize(K, 3) = dArr ' 3 COT
End Sub

PacificPR · 8/3/17

Bạn dùng hàm:

HTML:

LCase(String) ' chuyển đổi chuỗi sang chữ in thường
UCase (String) ' ngược với LCase

phulien1902 · 8/3/17

minhtuan55 đã viết:
Chào cả nhà GPE !
em đang tự học về Code Mãng Array , em cũng tự Viết 1 đoạn code lọc, code lọc thì ok, nhưng em muốn code không phân biệt chữ HOA và Chữ thường thì phải sửa lại làm sao. mong mọi người giúp em

Mã:

Sub LOC() On Error Resume Next Dim sArr(), dArr(), Dk1 As String, Dk2 As Long, I As Long, K As Long, R As Long, Col As Long Dk1 = Range("H4"): Dk2 = Range("I4") ' DIEU KIEN TU CHO sArr = Range("B4:D15000").Value ' DU LIEU DAU VAO R = UBound(sArr) ReDim dArr(1 To R, 1 To 3) ' 3 COT For I = 1 To R If sArr(I, 1) = Dk1 And sArr(I, 2) = Dk2 Then ' DIEU KIEN TUY CHINH K = K + 1 For Col = 1 To 3 ' 3 COT dArr(K, Col) = sArr(I, Col) Next Col End If Next I ' OUTPUT Range("L4").Resize(R, 3).ClearContents ' 3 COT Range("L4").Resize(K, 3) = dArr ' 3 COT End Sub

Bạn thử thay dòng:

Mã:

[COLOR=#000000]If sArr(I, 1) = Dk1 And sArr(I, 2) = Dk2 Then[/COLOR]

bằng:

Mã:

If UCase(sArr(I, 1)) = Dk1 And sArr(I, 2) = Dk2 Or LCase(sArr(I, 1)) = Dk1 And sArr(I, 2) = Dk2 Then

minhtuan55 · 8/3/17

phulien1902 đã viết:
Bạn thử thay dòng:

Mã:

[COLOR=#000000]If sArr(I, 1) = Dk1 And sArr(I, 2) = Dk2 Then[/COLOR]

bằng:

Mã:

If UCase(sArr(I, 1)) = Dk1 And sArr(I, 2) = Dk2 Or LCase(sArr(I, 1)) = Dk1 And sArr(I, 2) = Dk2 Then

Dạ em cảm ơn anh Nhiều lắm.Nhưng em cảm thấy code chưa chính xác 100% được.Ví dụ mã hàng có tên là "Gpe" thì không đúng, Vì UCase thi thành GPE mà LCase thỉ thành gpe. Anh phải làm sao nó giống như công thức Excel ( gpe = GPE = True )

TheThienChu · 8/3/17

minhtuan55 đã viết:
Mã:

If sArr(I, 1) = Dk1 And sArr(I, 2) = Dk2 Then ' DIEU KIEN TUY CHINH

Dùng ucase hoặc lcase cho cả 2 vế của biểu thức so sánh

Mã:

If ucase(sArr(I, 1)) = ucase(Dk1) And ucase(sArr(I, 2)) = ucase(Dk2) Then ' DIEU KIEN TUY CHINH

phulien1902 · 9/3/17

minhtuan55 đã viết:
Dạ em cảm ơn anh Nhiều lắm.Nhưng em cảm thấy code chưa chính xác 100% được.Ví dụ mã hàng có tên là "Gpe" thì không đúng, Vì UCase thi thành GPE mà LCase thỉ thành gpe. Anh phải làm sao nó giống như công thức Excel ( gpe = GPE = True )

Tôi có sửa Code của bạn 1 chút:

PHP:

Sub loc()
    On Error Resume Next
    Dim sarr(), dArr(), Dk1 As String, Dk2 As Long, i As Long, k As Long, R As Long, Col As Long
    Dk1 = Range("H4"): Dk2 = Range("I4")
    sarr = Range("B4").CurrentRegion    'Change
    R = UBound(sarr)
    ReDim dArr(1 To R, 1 To 3)
    Application.ScreenUpdating = 0
    For i = 1 To R
        If abc(sarr(i, 1)) Like abc(Dk1) And sarr(i, 2) = Dk2 Then
            k = k + 1
            For Col = 1 To 3
                dArr(k, Col) = sarr(i, Col)
            Next Col
        End If
    Next i
    Range("L4").Resize(R, 3).ClearContents
    Range("L4").Resize(k, 3) = dArr
    Range("L4").Resize(k, 3).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = 1
End Sub

Private Function abc(ByVal Text As String) As String
    Dim CharCode, ResText As String, i As Long, tmp As String
    tmp = LCase(WorksheetFunction.Trim(Text))
    CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                     ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                     ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                     ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                     ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                     ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                     ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                     ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                     ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
    ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
    For i = 0 To UBound(CharCode)
        tmp = Replace(tmp, CharCode(i), Mid(ResText, i + 1, 1))
    Next
    abc = tmp
End Function

VetMini · 9/3/17

phulien1902 đã viết:

Tôi có sửa Code của bạn 1 chút:

PHP:

Sub loc()
    On Error Resume Next
    Dim sarr(), dArr(), Dk1 As String, Dk2 As Long, i As Long, k As Long, R As Long, Col As Long
    Dk1 = Range("H4"): Dk2 = Range("I4")
    sarr = Range("B4").CurrentRegion    'Change'
    R = UBound(sarr)
    ReDim dArr(1 To R, 1 To 3)
    Application.ScreenUpdating = 0
    For i = 1 To R
        If abc(sarr(i, 1)) Like abc(Dk1) And sarr(i, 2) = Dk2 Then
            k = k + 1
            For Col = 1 To 3
                dArr(k, Col) = sarr(i, Col)
            Next Col
        End If
    Next i
    Range("L4").Resize(R, 3).ClearContents
    Range("L4").Resize(k, 3) = dArr
    Range("L4").Resize(k, 3).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = 1
End Sub

Private Function abc(ByVal Text As String) As String
    Dim CharCode, ResText As String, i As Long, tmp As String
    tmp = LCase(WorksheetFunction.Trim(Text))
    CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                     ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                     ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                     ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                     ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                     ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                     ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                     ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                     ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
    ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
    For i = 0 To UBound(CharCode)
        tmp = Replace(tmp, CharCode(i), Mid(ResText, i + 1, 1))
    Next
    abc = tmp
End Function

Theo code này mỗi lần được gọi, hàm abc lại phải dùng hàm array để lập lên cái mảng ChrW. Mảng này chính ra là một mảng hằng (không hề thay đổi), nếu viết đúng thì chỉ cần lập 1 lần thôi.

Hàm chính gọi hàm abc tất cả R * 2 lần!

Chú thích: code nguyên bản từ chủ thớt có cái câu On Error Resume Next, chẳng hiểu để làm gì.
Theo lý thuyết, dùng câu này rất dễ bị lỗi bỏ sót dữ liệu. Bởi vì cứ gặp vấn đề thì code sẽ lướt qua.

Hai Lúa Miền Tây · 9/3/17

Dùng Ucase là được mà

If UCase(sArr(I, 1)) = UCase(Dk1) And sArr(I, 2) = Dk2 Then ' DIEU KIEN TUY CHINH

VetMini · 9/3/17

Khi so sánh chuỗi có lúc cần phân biệt hoa thường và có lúc không thì mới phải dùng hàm UCase để đồng bộ.
Nếu phép so sánh luôn luôn không cần phân biệt thì chỉ cần nhét câu này vào đầu module:
Option Compare Text

minhtuan55 · 9/3/17

VetMini đã viết:
Theo code này mỗi lần được gọi, hàm abc lại phải dùng hàm array để lập lên cái mảng ChrW. Mảng này chính ra là một mảng hằng (không hề thay đổi), nếu viết đúng thì chỉ cần lập 1 lần thôi.

Hàm chính gọi hàm abc tất cả R * 2 lần!

Chú thích: code nguyên bản từ chủ thớt có cái câu On Error Resume Next, chẳng hiểu để làm gì.
Theo lý thuyết, dùng câu này rất dễ bị lỗi bỏ sót dữ liệu. Bởi vì cứ gặp vấn đề thì code sẽ lướt qua.

Dạ em dùng On Error Resume Next để khi Trường hợp Khi Mã hàng không có trong vùng dữ liệu. để code không bị lỗi anh nhé

phulien1902 · 9/3/17

VetMini đã viết:
.......... chỉ cần nhét câu này vào đầu module:
Option Compare Text

Cảm ơn VetMini, tôi đã học được 1 cách ở bạn.

Giúp sửa code lọc vba (1 người xem)

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

minhtuan55

Thành viên bị đình chỉ hoạt động

File đính kèm

PacificPR

Thành viên mới

phulien1902

GPE - My love

minhtuan55

Thành viên bị đình chỉ hoạt động

TheThienChu

Thành viên tiêu biểu

phulien1902

GPE - My love

File đính kèm

VetMini

Ăn cùng góc phố

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

VetMini

Ăn cùng góc phố

minhtuan55

Thành viên bị đình chỉ hoạt động

phulien1902

GPE - My love

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

Đếm ngược thời gian