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

baucua · 31/7/10

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 /-*+/

khoavu87 · 31/7/10

baucua đã viết:
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

-bạn tham khảo code này của ndu xem sao/

sealand · 31/7/10

Mình thấy code hơi rối, nên tham gia code khác. Code của mình vừa lọc vừa sắp xếp

Mã:

Function Dsach(ByVal Rg As Range, id As Integer)
Dim cl As Range, mg(), i, j, tam
Dim DS As New Collection
Application.Volatile
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)
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

sealand · 31/7/10

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

Mã:

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

ndu96081631 · 1/8/10

sealand đã viết:
Mình thấy code hơi rối, nên tham gia code khác. Code của mình vừa lọc vừa sắp xếp

Cái code "hơi rối" ấy có thể lọc được vùng dữ liệu không liên tục luôn đấy anh Sealand à ---> Ngoài ra nó cũng có thể biến kết quả thành dòng hay cột tùy thích nữa đấy
Anh xem ở đây:
http://www.giaiphapexcel.com/forum/...y-dữ-liệu-từ-nhiều-hàng-thành-1-hàng-và-1-cột

sealand · 1/8/10

Đúng là mình chưa Test nhưng đã UDF rồi mà lại tiếp tục dùng bằng công thức mảng nữa nên ngại. Hơn nữa, code đó mới chuyển vùng thành cột hay hàng chứ chưa làm việc lọc DS duy nhất

ndu96081631 · 2/8/10

sealand đã viết:
Đúng là mình chưa Test nhưng đã UDF rồi mà lại tiếp tục dùng bằng công thức mảng nữa nên ngại. Hơn nữa, code đó mới chuyển vùng thành cột hay hàng chứ chưa làm việc lọc DS duy nhất

Nếu dùng UDF thì cũng đâu cần nhiều vòng lập thế anh ơi!
Em dùng 1 vòng lập đây:

PHP:

Function Dsach(ByVal SrcRng As Range, id As Long)
  Dim TmpArr, Item
  TmpArr = SrcRng
  For Each Item In TmpArr
    If Trim(Item) <> "" Then
      id = id - 1
      If id = 0 Then
        Dsach = Item
        Exit Function
      End If
    End If
  Next
End Function

Cú pháp hàm cũng giống như anh đã trình bày (=DSach( SrcRng , id ))

baucua · 2/8/10

Các bác giúp E sửa cái CT mà E sưu tầm được không ?
E muốn CT đó lọc mảng nhưng theo các cột dữ liệu ko liền nhau :

PHP:

{= OB(mảng_cột_1,mảng cột 2,..,mảng_cột_n)}

Ví dụ mảng cột ko liền nhau: A5:A11: 1 3 4 1 2 3 C7:C11 : 90 4 5 6 7 E9:E11 : df r r

ndu96081631 · 2/8/10

baucua đã viết:
Các bác giúp E sửa cái CT mà E sưu tầm được không ?
E muốn CT đó lọc mảng nhưng theo các cột dữ liệu ko liền nhau :

PHP:

{= OB(mảng_cột_1,mảng cột 2,..,mảng_cột_n)}

CT gì gì nó là cái gì? File đâu?
Và 1 câu hỏi nhỏ: Bạn muốn code là 1 Sub hay 1 Function?

baucua · 2/8/10

File đó đây ạ, bác sửa giùm cái code đó loại hàng trống nhé: Sao hôm nay E vào GPE chậm rì rì vậy

ndu96081631 · 2/8/10

baucua đã viết:
File đó đây ạ, bác sửa giùm cái code đó loại hàng trống nhé: Sao hôm nay E vào GPE chậm rì rì vậy

Code của bạn tôi sửa thành vầy:

PHP:

Function OB(ParamArray SrcArr())
  Dim TmpArr, Item, i As Long, j As Long, Arr(1 To 10000, 1 To 1)
  For i = LBound(SrcArr) To UBound(SrcArr)
    TmpArr = SrcArr(i)
    For Each Item In TmpArr
      If Trim(Item) <> "" And Item <> 0 Then
        j = j + 1
        Arr(j, 1) = Item
      End If
    Next
  Next
  OB = Arr
End Function

Sử dụng:
- Quét chọn 1 vùng tùy ý (1 cột nhiều dòng)
- Gõ vào thanh Formula công thức =OB(Vùng 1, Vùng 2, Vùng 3,....., Vùng n)
- Ví dụ: =OB(A5:A11,C7:C11,E9:E11)
------------------------
Mạng GPE từ sáng đến giờ đúng là chậm quá trời đi thôi

sealand · 2/8/10

ndu96081631 đã viết:
Nếu dùng UDF thì cũng đâu cần nhiều vòng lập thế anh ơi!
.....................
Cú pháp hàm cũng giống như anh đã trình bày (=DSach( SrcRng , id ))

Đúng là Ndu luôn tìm cách tối ưu code.
Nhưng đoạn Code của Ndu còn thiếu 2 phần:

-Lọc Danh sách duy nhất.
-Sắp xếp lại.

Chính vì vậy, nó cũng bớt đi khá số lượng vòng lặp.

ndu96081631 · 2/8/10

sealand đã viết:
Đúng là Ndu luôn tìm cách tối ưu code.
Nhưng đoạn Code của Ndu còn thiếu 2 phần:
-Lọc Danh sách duy nhất.
-Sắp xếp lại.

Chính vì vậy, nó cũng bớt đi khá số lượng vòng lặp.

Vâng! Nhưng em đâu nghe tác giả đề cập đến vụ LỌC DUY NHẤT... chính thể mà em không dùng Collection hay Dictionary
Mà cho dù có lọc duy nhất thì em cũng dùng 1 vòng lập thôi anh à!
Ví dụ thế này

PHP:

Function Dsach(ByVal SrcRng As Range, id As Long)
  Dim TmpArr, Item
  TmpArr = SrcRng
  With CreateObject("Scripting.Dictionary")
    For Each Item In TmpArr
      If Trim(Item) <> "" And Not .Exists(Item) Then
        id = id - 1
        .Add Item, ""
        If id = 0 Then
          Dsach = Item
          Exit Function
        End If
      End If
    Next
  End With
End Function

Và nếu có thêm vụ SORT thì em sẽ dùng cái này:
http://www.giaiphapexcel.com/forum/showthread.php?38005-Sắp-xếp-mảng-dữ-liệu-không-sử-dụng-vòng-lặp
Cũng không vòng lập luôn!
Anh kiểm tra lại xem có gì không ổn không?

sealand · 2/8/10

Ôi cái vụ Sort này hay quá đi mất. Mình không phát hiện ra nó có trên GPE.
À, yêu cầu duy nhất là từ bài 1 cơ.

ndu96081631 · 2/8/10

sealand đã viết:
Ôi cái vụ Sort này hay quá đi mất. Mình không phát hiện ra nó có trên GPE.
À, yêu cầu duy nhất là từ bài 1 cơ.

Oh... em không đọc kỹ yêu cầu rồi...
Vậy em sửa lại code trên nhé:

PHP:

Function OB(ParamArray SrcArr())
  Dim TmpArr, Item, i As Long, j As Long, Arr(1 To 10000, 1 To 1)
  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
            j = j + 1
            .Add Item, j
            Arr(j, 1) = Item
          End If
        End If
      Next
    Next
    OB = Arr
  End With
End Function

Code này vẫn chưa sorf ---> Muốn sort, hãy dùng hàm của rollover79 lồng vào

Ếch Xanh · 2/8/10

Xin lỗi post sai chỗ! Xin Xóa dùm bài này!

ndu96081631 · 2/8/10

Learning_Excel đã viết:
Xin lỗi post sai chỗ! Xin Xóa dùm bài này!

Hi... hi... bạn làm tôi cũng... sai theo rồi nhé

sealand · 2/8/10

ndu96081631 đã viết:
Code này vẫn chưa sorf ---> Muốn sort, hãy dùng hàm của rollover79 lồng vào

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

baucua · 3/8/10

Thật tuyệt, code bác ndu96081631 đã đáp ứng đúng yêu cầu E rùi :

PHP:

 Function OB(ParamArray SrcArr())
  Dim TmpArr, Item, i As Long, j As Long, Arr(1 To 10000, 1 To 1)
  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
            j = j + 1
            .Add Item, j
            Arr(j, 1) = Item
          End If
        End If
      Next
    Next
    OB = Arr
  End With
End Function

Nhân tiện bác có thể chú thích thuật toán này ko?, vì E thấy ứng dụng này rất hay dùng trong thực tế.
Thank so much!!!

ThuNghi · 3/8/10

sealand đã viết:
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.

ndu96081631 · 3/8/10

sealand đã viết:
Tai sao mình lồng vào toàn báo lỗi nhỉ?

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

ThuNghi đã viết:
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:

PHP:

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

PHP:

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 · 19/9/15

sealand đã viết:

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

Mã:

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

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

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

Thành viên mới

File đính kèm

Vũ Trần Khoa

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

Huyền thoại GPE

Thành viên gạo cội

Huyền thoại GPE

File đính kèm

Thành viên mới

Huyền thoại GPE

Thành viên mới

File đính kèm

Huyền thoại GPE

File đính kèm

Thành viên gạo cội

Huyền thoại GPE

Thành viên gạo cội

Huyền thoại GPE

File đính kèm

Thành viên tích cực

Huyền thoại GPE

Thành viên gạo cội

Thành viên mới

Hãy cho rồi sẽ nhận!

Huyền thoại GPE

File đính kèm

Thành viên mới

Thời gian đếm ngược.