Xin hàm vba: Đếm-xếp hạng-và lấy kết quả

Liên hệ QC
N

nvh611

Thành viên thường trực
Tham gia
20/5/17
Bài viết
228
Được thích
42
Nhờ các bạn giúp đỡ như file đính kèm
 

File đính kèm

  • Đếm_Xếp hạng_Và lấy kết quả.xlsb
    8.5 KB · Đọc: 13
Sắp xếp theo thời gian sắp xếp theo bầu chọn
minhtuan55 đã viết:
Đến câu hỏi bạn cũng không biết cách trình bày thì làm sao mọi người hiểu được. Bạn định kèm file bạn không nói rõ là làm cái gì Input ở đâu Ouput xuất ra như thế nào thì lam sao họ giúp.
Nhấp chuột vào đây để mở rộng...
Mình cũng nói rõ trong file rồi đó
Nói tóm lại là tìm các giá trị trùng nhau
xép hạng từ 1 đến ..i bạn à
Thật sự dùng hàm của excel mình cũng chưa biết sử dụng cho trường hợp này
Vậy mong các bạn giúp đỡ
 
Upvote 0
Bước 1: Đếm các ký tự (Bước này tôi dùng công thức cũng không dúng)
Nhấp chuột vào đây để mở rộng...
Đếm các kí tự ở vùng nào?

Tóm lại viết cho người khác hiểu khác nhiều với việc viết những gì mình hiểu!
 
Upvote 0
nvh611 đã viết:
Chào bạn @HieuCD cảm ơn bạn đã quan tâm
Bạn làm giúp mình các giá trị là các số tự nhiên từ 00-99 bạn nhé
Nhấp chuột vào đây để mở rộng...
Lỡ làm cho cả ký tự chuỗi và số
Deli = Array(";", "-", "_", ".", ":") Chỉnh lại cho phù hợp
Mã: 
Function XepHang(ByVal iR As Long, ByVal jCol As Long, ParamArray sRng()) As Variant
  'XepHang(Hang thu, Cot, Vung du lieu 1, Vung du lieu 2, ...)
  Dim Rng, iCell, S, sList As Object, Arr() As String, Deli
  Dim tmp As String, j As Long, n As Long, k As Long, jk As Long
  iStr = UCase(iStr)
  Deli = Array(";", "-", "_", ".", ":")
  Set sList = CreateObject("System.Collections.SortedList")
  For Each Rng In sRng
    For Each iCell In Rng
      tmp = CStr(iCell)
      If Len(tmp) > 0 Then
        For j = 0 To UBound(Deli)
          tmp = Replace(tmp, Deli(j), ",")
        Next j
        S = Split(tmp, ",")
        For j = 0 To UBound(S)
          iKey = UCase(S(j))
          If Not sList.Contains(iKey) Then
            k = k + 1
            ReDim Preserve Arr(1 To 2, 1 To k)
            Arr(1, k) = S(j): Arr(2, k) = 1
            sList.Item(iKey) = k
          Else
            jk = sList.Item(iKey)
            Arr(2, jk) = Arr(2, jk) + 1
          End If
        Next j
      End If
    Next
  Next
  sList.Clear
  For j = 1 To k
    iKey = Arr(2, j)
    If Not sList.Contains(iKey) Then n = n + 1
    sList.Item(iKey) = sList.Item(iKey) & "-" & Arr(1, j)
  Next j
  ReDim Arr(1 To n, 1 To 2)
  k = 0
  For j = sList.Count - 1 To 0 Step -1
    k = k + 1
    Arr(k, 1) = Replace(sList.GetByIndex(j), "-", "", 1, 1)
    Arr(k, 2) = sList.getkey(j)
  Next j
  If iR <= k Then XepHang = Arr(iR, jCol) Else XepHang = ""
End Function
 

File đính kèm

  • Đếm_Xếp hạng_Và lấy kết quả.xlsb
    17.5 KB · Đọc: 22
Upvote 0
HieuCD đã viết:
Lỡ làm cho cả ký tự chuỗi và số
Deli = Array(";", "-", "_", ".", ":") Chỉnh lại cho phù hợp
Mã: 
Function XepHang(ByVal iR As Long, ByVal jCol As Long, ParamArray sRng()) As Variant
  'XepHang(Hang thu, Cot, Vung du lieu 1, Vung du lieu 2, ...)
  Dim Rng, iCell, S, sList As Object, Arr() As String, Deli
  Dim tmp As String, j As Long, n As Long, k As Long, jk As Long
  iStr = UCase(iStr)
  Deli = Array(";", "-", "_", ".", ":")
  Set sList = CreateObject("System.Collections.SortedList")
  For Each Rng In sRng
    For Each iCell In Rng
      tmp = CStr(iCell)
      If Len(tmp) > 0 Then
        For j = 0 To UBound(Deli)
          tmp = Replace(tmp, Deli(j), ",")
        Next j
        S = Split(tmp, ",")
        For j = 0 To UBound(S)
          iKey = UCase(S(j))
          If Not sList.Contains(iKey) Then
            k = k + 1
            ReDim Preserve Arr(1 To 2, 1 To k)
            Arr(1, k) = S(j): Arr(2, k) = 1
            sList.Item(iKey) = k
          Else
            jk = sList.Item(iKey)
            Arr(2, jk) = Arr(2, jk) + 1
          End If
        Next j
      End If
    Next
  Next
  sList.Clear
  For j = 1 To k
    iKey = Arr(2, j)
    If Not sList.Contains(iKey) Then n = n + 1
    sList.Item(iKey) = sList.Item(iKey) & "-" & Arr(1, j)
  Next j
  ReDim Arr(1 To n, 1 To 2)
  k = 0
  For j = sList.Count - 1 To 0 Step -1
    k = k + 1
    Arr(k, 1) = Replace(sList.GetByIndex(j), "-", "", 1, 1)
    Arr(k, 2) = sList.getkey(j)
  Next j
  If iR <= k Then XepHang = Arr(iR, jCol) Else XepHang = ""
End Function
Nhấp chuột vào đây để mở rộng...
Quá chuẩn
Chuẩn không cần chỉnh
Cảm ơn bạn @HieuCD rất nhiều
Mình giới hạn từ 00-99 để bài toán đỡ phức tạp
Nhưng bạn đã làm được cho tất cả chuỗi ký tự bất kỳ
Khâm phục và kính nể bạn nhiều nhiều lắm
Cảm ơn bạn nhé!
 
Upvote 0
nvh611 đã viết:
Chào bạn @HieuCD cảm ơn bạn đã quan tâm
Bạn làm giúp mình các giá trị là các số tự nhiên từ 00-99 bạn nhé
Nhấp chuột vào đây để mở rộng...
Function với các giá trị từ "00" tới "99"
Mã: 
Function XepHangChuoi(ByVal iR As Long, ByVal jCol As Long, ParamArray sRng()) As Variant
  'XepHangChuoi(Hang thu, Cot, Vung du lieu 1, Vung du lieu 2, ...)
  Dim Rng, iCell, Arr() As String, Res()
  Dim iStr As String, tmp As String
  Dim j As Long, i As Long, k As Long, sRow As Long
  Const Deli As String = "-"
  For Each Rng In sRng
    For Each iCell In Rng
      If Len(iCell) > 0 Then tmp = tmp & "," & iCell
    Next
  Next
  n = Len(tmp)
  sRow = (n \ 3) + 1
  ReDim Arr(1 To sRow)
  For j = 0 To 99
    iStr = Format(j, "00")
    If InStr(1, tmp, iStr) > 0 Then
      i = (n - Len(Replace(tmp, iStr, ""))) / 2
      If Len(Arr(i)) = 0 Then
        k = k + 1
        Arr(i) = iStr
      Else
        Arr(i) = Arr(i) & Deli & iStr
      End If
    End If
  Next j
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = sRow To 1 Step -1
    If Len(Arr(i)) > 0 Then
      k = k + 1
      Res(k, 1) = Arr(i)
      Res(k, 2) = i
    End If
  Next i
  If iR <= k Then XepHangChuoi = Res(iR, jCol) Else XepHangChuoi = ""
End Function
 

File đính kèm

  • Đếm_Xếp hạng_Và lấy kết quả.xlsb
    20.4 KB · Đọc: 16
Upvote 0
HieuCD đã viết:
Lỡ làm cho cả ký tự chuỗi và số
Deli = Array(";", "-", "_", ".", ":") Chỉnh lại cho phù hợp
Mã: 
Function XepHang(ByVal iR As Long, ByVal jCol As Long, ParamArray sRng()) As Variant
  'XepHang(Hang thu, Cot, Vung du lieu 1, Vung du lieu 2, ...)
  Dim Rng, iCell, S, sList As Object, Arr() As String, Deli
  Dim tmp As String, j As Long, n As Long, k As Long, jk As Long
  iStr = UCase(iStr)
  Deli = Array(";", "-", "_", ".", ":")
  Set sList = CreateObject("System.Collections.SortedList")
  For Each Rng In sRng
    For Each iCell In Rng
      tmp = CStr(iCell)
      If Len(tmp) > 0 Then
        For j = 0 To UBound(Deli)
          tmp = Replace(tmp, Deli(j), ",")
        Next j
        S = Split(tmp, ",")
        For j = 0 To UBound(S)
          iKey = UCase(S(j))
          If Not sList.Contains(iKey) Then
            k = k + 1
            ReDim Preserve Arr(1 To 2, 1 To k)
            Arr(1, k) = S(j): Arr(2, k) = 1
            sList.Item(iKey) = k
          Else
            jk = sList.Item(iKey)
            Arr(2, jk) = Arr(2, jk) + 1
          End If
        Next j
      End If
    Next
  Next
  sList.Clear
  For j = 1 To k
    iKey = Arr(2, j)
    If Not sList.Contains(iKey) Then n = n + 1
    sList.Item(iKey) = sList.Item(iKey) & "-" & Arr(1, j)
  Next j
  ReDim Arr(1 To n, 1 To 2)
  k = 0
  For j = sList.Count - 1 To 0 Step -1
    k = k + 1
    Arr(k, 1) = Replace(sList.GetByIndex(j), "-", "", 1, 1)
    Arr(k, 2) = sList.getkey(j)
  Next j
  If iR <= k Then XepHang = Arr(iR, jCol) Else XepHang = ""
End Function
Nhấp chuột vào đây để mở rộng...
Bài toán này có nhiều ứng dụng thực tiễn quá anh
HieuCD
 
Upvote 0
HieuCD đã viết:
Function với các giá trị từ "00" tới "99"
Mã: 
Function XepHangChuoi(ByVal iR As Long, ByVal jCol As Long, ParamArray sRng()) As Variant
  'XepHangChuoi(Hang thu, Cot, Vung du lieu 1, Vung du lieu 2, ...)
  Dim Rng, iCell, Arr() As String, Res()
  Dim iStr As String, tmp As String
  Dim j As Long, i As Long, k As Long, sRow As Long
  Const Deli As String = "-"
  For Each Rng In sRng
    For Each iCell In Rng
      If Len(iCell) > 0 Then tmp = tmp & "," & iCell
    Next
  Next
  n = Len(tmp)
  sRow = (n \ 3) + 1
  ReDim Arr(1 To sRow)
  For j = 0 To 99
    iStr = Format(j, "00")
    If InStr(1, tmp, iStr) > 0 Then
      i = (n - Len(Replace(tmp, iStr, ""))) / 2
      If Len(Arr(i)) = 0 Then
        k = k + 1
        Arr(i) = iStr
      Else
        Arr(i) = Arr(i) & Deli & iStr
      End If
    End If
  Next j
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = sRow To 1 Step -1
    If Len(Arr(i)) > 0 Then
      k = k + 1
      Res(k, 1) = Arr(i)
      Res(k, 2) = i
    End If
  Next i
  If iR <= k Then XepHangChuoi = Res(iR, jCol) Else XepHangChuoi = ""
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn @HieuCD rất nhiều
Chắc mình sẽ dùng hàm đầu tiên vì nó tổng quát hơn
Nhưng có lẽ tốc độ xử lý sẽ chậm hơn code giới hạn này có phải không bạn @HieuCD
 
Upvote 0
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
3
Đọc
70
ptm0412
ptm0412
V
Tách chuỗi bất kỳ vào các cột khi gặp ký tự -
Trả lời
6
Đọc
182
Duy Tùng 9x
Duy Tùng 9x
C
  • Question
Tạo schedule chạy code VBA
Trả lời
7
Đọc
245
castanea
C
C
Giúp em viết công thức làm lịch thi đấu.
Trả lời
2
Đọc
45
SA_DQ
SA_DQ
LuuAnh980
Filter lọc có "mm" mà không thấy.
Trả lời
2
Đọc
42
CHAOQUAY
C
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom