Hàm lấy dữ liệu theo điều kiện đếm được

[hiénlinh197]

Nhờ các bạn viết giúp hàm như file đính kèm

 

[Ba Tê]

Nhờ các bạn viết giúp hàm như file đính kèm

B18 đến B31 là tự nhập thủ công?

Public Function Gpe(Rng1 As Range, Rng2 As Range, N As Long) As String
Dim Cll As Range
For Each Cll In Rng2
    If Application.WorksheetFunction.CountIf(Rng1, Cll.Value) >= N Then Gpe = Gpe & Cll.Value
Next Cll
End Function
Công thức:
=Gpe(C3:J9;B18:B31;3)

 

[snow25]

Nhờ các bạn viết giúp hàm như file đính kèm

Bạn xem đúng không nhé.

Function laydulieu(ByVal mang As Range, ByVal mang1 As Range, ByVal so As Long) As String
          Dim arr, arr1, s As String, dic As Object, T
          Set dic = CreateObject("SCripting.dictionary")
          dic.CompareMode = vbTextCompare
          For Each T In mang
              If Not dic.exists(T.Value) Then
                 dic.Add T.Value, 1
              Else
                 dic.Item(T.Value) = dic.Item(T.Value) + 1
             End If
          Next
          For Each T In mang1
              If dic.Item(T.Value) >= so Then
                 s = s & T.Value
              End If
          Next
          laydulieu = s
End Function

=laydulieu(C3:J9,B18:B31,3)

 

[HieuCD]

Nhờ các bạn viết giúp hàm như file đính kèm

Tạo cho bạn Function ghép các giá trị có tần số min, max và lớn hơn bằng số cho trước

Function NoiKyTu_TanSo(ByVal Rng As Range, ByVal Deli As String, Optional SoKyTu As Long = -1)
  'Mac dinh SoKyTu = -1, lay tan so nho nhat
  'SoKyTu = 0, lay tan so lon nhat
  'SoKyTu > 0, lay tan so >= SoKyTu
  Dim Arr(), Cel As Range, tmp, k As Long, n As Long, Res As String
 
  If SoKyTu < 1 Then
    ReDim Arr(1 To Rng.Count)
    If SoKyTu = -1 Then n = Rng.Count Else n = 0
  End If
  With CreateObject("scripting.dictionary")
    For Each Cel In Rng
      tmp = Cel.Value
      If Len(tmp) > 0 Then
        'Bo ca 2 dong duoi, phan biet dang so va chu hoa chu thuong
        If IsNumeric(tmp) Then tmp = Val(tmp) Else tmp = UCase(tmp) 'Khong phan biet dang so và chu hoa chu thuong
        'If TypeName(tmp) = "String" Then tmp = UCase(tmp) 'Phan biet dang so, khong phan biet chu hoa chu thuong
        k = .Item(tmp) + 1
        .Item(tmp) = k
        If SoKyTu > 0 Then
          If k = SoKyTu Then Res = Res & Deli & tmp
        End If
      End If
    Next Cel
    If SoKyTu < 1 Then
      For Each tmp In .keys
        k = .Item(tmp)
        Arr(k) = Arr(k) & Deli & tmp
        If (k > n) = (SoKyTu = 0) Then n = k
      Next
      Res = Arr(n)
    End If
  End With
  NoiKyTu_TanSo = Mid(Res, Len(Deli) + 1, Len(Res))
End Function

 

[hiénlinh197]

Tạo cho bạn Function ghép các giá trị có tần số min, max và lớn hơn bằng số cho trước

Function NoiKyTu_TanSo(ByVal Rng As Range, ByVal Deli As String, Optional SoKyTu As Long = -1)
  'Mac dinh SoKyTu = -1, lay tan so nho nhat
  'SoKyTu = 0, lay tan so lon nhat
  'SoKyTu > 0, lay tan so >= SoKyTu
  Dim Arr(), Cel As Range, tmp, k As Long, n As Long, Res As String

  If SoKyTu < 1 Then
    ReDim Arr(1 To Rng.Count)
    If SoKyTu = -1 Then n = Rng.Count Else n = 0
  End If
  With CreateObject("scripting.dictionary")
    For Each Cel In Rng
      tmp = Cel.Value
      If Len(tmp) > 0 Then
        'Bo ca 2 dong duoi, phan biet dang so va chu hoa chu thuong
        If IsNumeric(tmp) Then tmp = Val(tmp) Else tmp = UCase(tmp) 'Khong phan biet dang so và chu hoa chu thuong
        'If TypeName(tmp) = "String" Then tmp = UCase(tmp) 'Phan biet dang so, khong phan biet chu hoa chu thuong
        k = .Item(tmp) + 1
        .Item(tmp) = k
        If SoKyTu > 0 Then
          If k = SoKyTu Then Res = Res & Deli & tmp
        End If
      End If
    Next Cel
    If SoKyTu < 1 Then
      For Each tmp In .keys
        k = .Item(tmp)
        Arr(k) = Arr(k) & Deli & tmp
        If (k > n) = (SoKyTu = 0) Then n = k
      Next
      Res = Arr(n)
    End If
  End With
  NoiKyTu_TanSo = Mid(Res, Len(Deli) + 1, Len(Res))
End Function

Cảm ơn các bạn @HieuCD ; @snow25 ; @Ba Tê
Thật sự trong đầu bài mình cũng nói là "Làm sao để rút gọn các bước ngắn nhất"
Vì vậy code của bạn @Ba Tê và bạn @snow25 đã rút gọn được 50% các bước
rất cảm ơn các bạn
riêng code của anh @HieuCD là quá tuyệt đỉnh
em xin cảm ơn anh @HieuCD
Nhưng trong code của anh còn có 1 số lỗi là khi trong mảng có các lỗi #Value; #Div0/0...... thì code không hoạt động đươc
Em nhờ anh sửa giúp cho em công thức hoạt động được khi gặp các lỗi này với anh nhé
Cảm ơn anh
Chúc các anh chị và các bạn cuối tuần có nhiều niềm vui

 

[HieuCD]

Cảm ơn các bạn @HieuCD ; @snow25 ; @Ba Tê
Thật sự trong đầu bài mình cũng nói là "Làm sao để rút gọn các bước ngắn nhất"
Vì vậy code của bạn @Ba Tê và bạn @snow25 đã rút gọn được 50% các bước
rất cảm ơn các bạn
riêng code của anh @HieuCD là quá tuyệt đỉnh
em xin cảm ơn anh @HieuCD
Nhưng trong code của anh còn có 1 số lỗi là khi trong mảng có các lỗi #Value; #Div0/0...... thì code không hoạt động đươc
Em nhờ anh sửa giúp cho em công thức hoạt động được khi gặp các lỗi này với anh nhé
Cảm ơn anh
Chúc các anh chị và các bạn cuối tuần có nhiều niềm vui

Nếu muốn trả về cả kết quả lổi

Function NoiKyTu_TanSo(ByVal Rng As Range, ByVal Deli As String, Optional SoKyTu As Long = -1)
  'Mac dinh SoKyTu = -1, lay tan so nho nhat
  'SoKyTu = 0, lay tan so lon nhat
  'SoKyTu > 0, lay tan so >= SoKyTu
  Dim Arr(), Cel As Range, tmp, k As Long, n As Long, Res As String
 
  If SoKyTu < 1 Then
    ReDim Arr(1 To Rng.Count)
    If SoKyTu = -1 Then n = Rng.Count Else n = 0
  End If
  With CreateObject("scripting.dictionary")
    For Each Cel In Rng
      tmp = Cel.Value
      If TypeName(tmp) = "Error" Then tmp = Cel.Text
      If Len(tmp) > 0 Then
        'Bo ca 2 dong duoi, phan biet dang so va chu hoa chu thuong
        If IsNumeric(tmp) Then tmp = Val(tmp) Else tmp = UCase(tmp) 'Khong phan biet dang so và chu hoa chu thuong
        'If TypeName(tmp) = "String" Then tmp = UCase(tmp) 'Phan biet dang so, khong phan biet chu hoa chu thuong
        k = .Item(tmp) + 1
        .Item(tmp) = k
        If SoKyTu > 0 Then
          If k = SoKyTu Then Res = Res & Deli & tmp
        End If
      End If
    Next Cel
    If SoKyTu < 1 Then
      For Each tmp In .keys
        k = .Item(tmp)
        Arr(k) = Arr(k) & Deli & tmp
        If (k > n) = (SoKyTu = 0) Then n = k
      Next
      Res = Arr(n)
    End If
  End With
  NoiKyTu_TanSo = Mid(Res, Len(Deli) + 1, Len(Res))
End Function

 

[hiénlinh197]

Nếu muốn trả về cả kết quả lổi

Function NoiKyTu_TanSo(ByVal Rng As Range, ByVal Deli As String, Optional SoKyTu As Long = -1)
  'Mac dinh SoKyTu = -1, lay tan so nho nhat
  'SoKyTu = 0, lay tan so lon nhat
  'SoKyTu > 0, lay tan so >= SoKyTu
  Dim Arr(), Cel As Range, tmp, k As Long, n As Long, Res As String

  If SoKyTu < 1 Then
    ReDim Arr(1 To Rng.Count)
    If SoKyTu = -1 Then n = Rng.Count Else n = 0
  End If
  With CreateObject("scripting.dictionary")
    For Each Cel In Rng
      tmp = Cel.Value
      If TypeName(tmp) = "Error" Then tmp = Cel.Text
      If Len(tmp) > 0 Then
        'Bo ca 2 dong duoi, phan biet dang so va chu hoa chu thuong
        If IsNumeric(tmp) Then tmp = Val(tmp) Else tmp = UCase(tmp) 'Khong phan biet dang so và chu hoa chu thuong
        'If TypeName(tmp) = "String" Then tmp = UCase(tmp) 'Phan biet dang so, khong phan biet chu hoa chu thuong
        k = .Item(tmp) + 1
        .Item(tmp) = k
        If SoKyTu > 0 Then
          If k = SoKyTu Then Res = Res & Deli & tmp
        End If
      End If
    Next Cel
    If SoKyTu < 1 Then
      For Each tmp In .keys
        k = .Item(tmp)
        Arr(k) = Arr(k) & Deli & tmp
        If (k > n) = (SoKyTu = 0) Then n = k
      Next
      Res = Arr(n)
    End If
  End With
  NoiKyTu_TanSo = Mid(Res, Len(Deli) + 1, Len(Res))
End Function

Anh ơi chuẩn lắm rồi
Cảm ơn anh @HieuCD rất nhiều
chúc anh cuối tuần vui vẻ, hạnh phúc