Giúp em lọc dữ liệu trả kết quả về ở 1 Cell.

[Duong_VBA]

Em có bài toán, em nghĩ chưa ra cách giải tối ưu nhờ các bác giúp đỡ.
Em muốn lấy tên người ra khỏi 1 danh sách theo 2 điều kiện, kết quả có thể là hàng nghìn tên, yêu cầu kết quả trả về đặt ở 1 cell (Các tên cách nhau 1 dấu /)
Các bác xem file đính kèm và giúp em với!
Cảm ơn!

 

[ndu96081631]

Thử với Sub "cua" này xem:

Sub Noichuoi()
  Dim Clls As Range
  With Range("A2").CurrentRegion
    .AutoFilter 1, "<2": .AutoFilter 2, "=0", 2, "="
    For Each Clls In .Offset(1, 2).Resize(, 1).SpecialCells(2).SpecialCells(12)
      Temp = Temp & "/" & Clls
    Next
    .AutoFilter
  End With
  [F7] = Mid(Temp, 2, Len(Temp))
End Sub

Rảnh rổi viết thành 1 UDF chắc không có vấn đề

 

[cadafi]

Em có bài toán, em nghĩ chưa ra cách giải tối ưu nhờ các bác giúp đỡ.
Em muốn lấy tên người ra khỏi 1 danh sách theo 2 điều kiện, kết quả có thể là hàng nghìn tên, yêu cầu kết quả trả về đặt ở 1 cell (Các tên cách nhau 1 dấu /)
Các bác xem file đính kèm và giúp em với!
Cảm ơn!

Code này dùng để tạo một hàm UDF giải quyết việc này:

Function MyConcat(Rng As Range, Optional MySps As String = "/") As String
Dim myText As String
myText = ""
For i = 1 To Rng.Rows.Count
    If Rng.Cells(i, 1) < 2 And (Rng.Cells(i, 2) = "" Or Rng.Cells(i, 2) = 0) Then _
    myText = myText & MySps & Rng.Cells(i, 3).Value
Next i
MyConcat = Right(myText, Len(myText) - Len(MySps))
End Function

Bạn xem file đính kèm nhé!

Cú pháp hàm:

= MyConcat(Vùng dữ liệu, ký tự phân cách)

Trong đó:
Vùng dữ liệu: bắt buộc phải có ba cột, trong ví dụ bạn chọn vùng dữ liệu là [A3:C12]
Ký tự phân cách: mặc định là "/", có thể thay đổi thành ký tự khác, ví dụ "-", hoặc "*", hoặc tùy thích

 

[hoangvuluan]

aJoint

Em có bài toán, em nghĩ chưa ra cách giải tối ưu nhờ các bác giúp đỡ.
Em muốn lấy tên người ra khỏi 1 danh sách theo 2 điều kiện, kết quả có thể là hàng nghìn tên, yêu cầu kết quả trả về đặt ở 1 cell (Các tên cách nhau 1 dấu /)
Các bác xem file đính kèm và giúp em với!
Cảm ơn!

Bạn dùng macro sau:

Sub aJoint()
' MaSo = [A2] dat ten de quan ly diem dau tien cua bang du lieu'
Const MaSo = "MaSo"
Dim Sh As Worksheet
Dim r1 As Range, Rng As Range
Dim str As String, iRow As Long
    Application.ScreenUpdating = False
    Set Sh = ActiveSheet
    ' Có thể đổi thành Set r1 = Sh.Range("A2") '
    Set r1 = Sh.Range(MaSo)
    Set Rng = r1.CurrentRegion
    
    iRow = Rng.Rows.Count
    
    Sh.AutoFilterMode = False
    
    Rng.AutoFilter field:=1, Criteria1:="<2"
    Rng.AutoFilter field:=2, Criteria1:="<=0", Operator:=xlOr, Criteria2:="="
       
    Set Rng = r1.Offset(1, 2).Resize(iRow - 1, 1).SpecialCells(Type:=xlCellTypeVisible)
    
    For Each r1 In Rng
        str = str & r1 & "/"
    Next
    ' F7 la o chua du lieu ket qua '
    [F7] = Left$(str, Len(str) - 1)
    
    Sh.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Trong đó lưu ý: tôi tạm đặt tên cho ô A2 là MaSo và ô F7 sẽ chứa kết quả.

 

[ThuNghi]

Em có bài toán, em nghĩ chưa ra cách giải tối ưu nhờ các bác giúp đỡ.
Em muốn lấy tên người ra khỏi 1 danh sách theo 2 điều kiện, kết quả có thể là hàng nghìn tên, yêu cầu kết quả trả về đặt ở 1 cell (Các tên cách nhau 1 dấu /)
Các bác xem file đính kèm và giúp em với!
Cảm ơn!

Không biết có cần lây duy nhất, if not dùng thử code sau.

Function CatTen(Rng As Range)
Dim myText As String, j As Long
Dim Names()
myText = ""
For i = 1 To Rng.Rows.Count
    If Rng.Cells(i, 1) < 2 And (Rng.Cells(i, 2) = "" Or Rng.Cells(i, 2) = 0) Then
        j = j + 1
        ReDim Preserve Names(1 To j)
        Names(j) = Rng.Cells(i, 3).Value
    End If
Next i
myText = Join(Names(), "/")
CatTen = myText
End Function

 

[ndu96081631]

Bài này "ác liệt" ở chổ nếu dùng "Sub măng cua" bình thường thì ta có thể tận dụng được các lợi thế của công cụ AutoFilter, SpecialCells... vân vân... nhằm tăng tốc độ tính toán... nhưng nếu chuyển sang UDF thì chỉ có thể For từ trên xuống mà thôi...
Không biết để tăng tốc độ thì có "chiêu" nào cho UDF không ta?