Sửa lại code lọc mảng (1 người xem)

[baucua]

Cái này E sưu tầm trên GPE
Các bác sửa giúp E lại cái code lọc mảng,
phần kết quả có hàng rỗng thành danh sách duy nhất ko có hàng rỗng nhé.
Các bác xem file đính kèm

 

[ndu96081631]

Tai sao mình lồng vào toàn báo lỗi nhỉ?

---------------

Em cũng đọc thấy code về Java của Rollover và vận dụng của NDU mà cũng hú thật là chưa biết cách truyền tham số (lồng) code trên vào để sort.
Mong NDU và Rollover cụ thể giúp.
Cám ơn.

Hi... hi... Chỉ có thể sai 1 chổ thôi, đó là hàm SortArray của rollover79 chỉ làm việc với mảng 1 chiều ---> Đối với mảng 2 chiều nó sẽ báo lỗi ngay chổ nào có dùng đến hàm JOIN
Mình kết hợp 2 cái thế này:

Function SortArray(arr, Optional isText As Boolean = False, Optional isDESC As Boolean = False)
    Dim sCommand As String
    sCommand = "('" & Join(arr, vbBack) & "').split('" & vbBack & "').sort("
    If isText Then
        sCommand = sCommand & ")"
    Else
        sCommand = sCommand & "function(a,b){return (a-b)})"
    End If
    If isDESC Then sCommand = sCommand & ".reverse()"
    sCommand = sCommand & ".join('" & vbBack & "')"
    Dim objSC
    Set objSC = CreateObject("MSScriptControl.ScriptControl")
    objSC.Language = "JavaScript"
    SortArray = Split(objSC.Eval(sCommand), vbBack)
End Function

Function OB(ParamArray SrcArr())
  Dim TmpArr, Item, i As Long
  With CreateObject("Scripting.Dictionary")
    For i = LBound(SrcArr) To UBound(SrcArr)
      TmpArr = SrcArr(i)
      For Each Item In TmpArr
        If Trim(Item) <> "" And Item <> 0 Then
          If Not .Exists(Item) Then
            .Add Item, ""
          End If
        End If
      Next
    Next
    OB = WorksheetFunction.Transpose(SortArray(.Keys, True))
  End With
End Function

 

[hdg2318]

Mình hiệu chính Code 1 chút:

Function Dsach(ByVal Rg As Range, id As Integer)
   Dim cl As Range, mg(), i, j, tam
     Dim DS As New Collection
      On Error Resume Next
         For Each cl In Rg.Cells
          If Trim(cl) <> "" Then DS.Add cl.Value, CStr(cl.Value)
         Next
ReDim mg(DS.Count)
  For i = 1 To DS.Count: mg(i - 1) = DS(i): Next
For i = 0 To UBound(mg) - 1
 For j = i + 1 To DS.Count - 1
  If mg(i) > mg(j) Then
    tam = mg(i): mg(i) = mg(j): mg(j) = tam
   End If: Next: Next
If id > UBound(mg) Then
Dsach = ""
Else
Dsach = mg(id - 1)
End If
End Function

Cú pháp : = DSach( Rg , id )
​

Trong đó:

Rg: Vùng nguồn tạo danh sách.
Id: Số phần tử của Danh sách
​

Hôm nay em mới tìm được bài này của bác, bác có thể thêm tùy chọn chỉ lọc cho text giúp e được ko ạ.

Thanks bác