Nhờ Anh chị trợ giúp code sắp xếp giữ liệu số lượng giá trị từ lớn đến nhỏ.

[TuPham86]

Em có một bài toán muốn xin được trợ gúp ạ, bài toán của em, em muốn sắp xếp giữ liệu từ bảng dữ liệu và lớp (cột A và cột B), bài toán của em muốn ra kết quả như ra cột G, trong đó ô kết quả được sắp xếp theo trình tự theo số lượng như (có 3 giá trị B, 2 giá trị C.......) từ lớn đến bé, thì được kết quả như cột G1 hoặc G2 ở các lớp khác nhau ạ. em xin cảm ơn các bác. file e có đính kèm để dưới ạ. Năm mới chúc các bác luôn mạnh khỏe và nhiều may mắn.

 

[SA_DQ]

Chưa đúng ý bạn lắm, tham khảo xem nha:

Sub ThongKeGiaiTheoLop()
 Dim Rws As Long, J As Integer, Dem As Integer, W As Byte
 Dim MyAdd As String, Tmp As String
 Dim Rng As Range, sRng As Range
 Const Col As Byte = 2

 Rws = [B2].CurrentRegion.Rows.Count
 ReDim Arr(1 To 1 + Rws, 1 To 3)
 Set Rng = [A2].Resize(Rws):        [D5].Resize(26, 3).Value = Space(0)
 Arr(1, 1) = "Du Liêu":             Arr(1, 2) = "Lóp 6A"
 Arr(1, 3) = "Lóp 6B":                  W = 1
 For J = 1 To 26
    Tmp = Chr(64 + J)
    Set sRng = Rng.Find(Tmp, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        W = W + 1:                  MyAdd = sRng.Address
        Arr(W, 1) = Tmp
        Do
            If sRng.Offset(, 1).Value = "6a" Then
                Arr(W, 2) = Arr(W, 2) + 1
            ElseIf sRng.Offset(, 1).Value = "6b" Then
                Arr(W, 3) = 1 + Arr(W, 3)
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 Next J
 [D5].Resize(W, 3).Value = Arr()
End Sub

 

[HieuCD]

Em có một bài toán muốn xin được trợ gúp ạ, bài toán của em, em muốn sắp xếp giữ liệu từ bảng dữ liệu và lớp (cột A và cột B), bài toán của em muốn ra kết quả như ra cột G, trong đó ô kết quả được sắp xếp theo trình tự theo số lượng như (có 3 giá trị B, 2 giá trị C.......) từ lớn đến bé, thì được kết quả như cột G1 hoặc G2 ở các lớp khác nhau ạ. em xin cảm ơn các bác. file e có đính kèm để dưới ạ. Năm mới chúc các bác luôn mạnh khỏe và nhiều may mắn.
View attachment 254332

Chạy code

Sub XYZ()
  Dim sArr(), Arr(), tmp, Res(), iKey$, iKey2$
  Dim sRow&, i&, k&, iR&, j&, c&, jC&, t&
  Const n = 10 'Gioi han So luong loai du lieu A,B ...
 
  With Sheets("Sheet1")
    i = Range("A" & Rows.Count).End(xlUp).Row
    If i < 1 Then MsgBox "Khong co du lieu": Exit Sub
    sArr = Range("A2:B" & i).Value
  End With
  sRow = UBound(sArr)
 
  ReDim Arr(0 To n, 1 To 2) 'Mang du lieu tung Lop
  ReDim Res(1 To sRow, 1 To 3)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      iKey = sArr(i, 2)
      iKey2 = iKey & "|" & sArr(i, 1)
      If .exists(iKey) = False Then
        k = k + 1
        .Add iKey, k
        Res(k, 1) = iKey
        Res(k, 3) = Arr 'Mang du lieu tung Lop
      End If
      iR = .Item(iKey)
      tmp = Res(iR, 3) 'Mang du lieu tung Lop
      j = tmp(0, 1)
      If .exists(iKey2) = False Then
        j = j + 1 ' Thu tu du kieu
        .Add iKey2, j
        tmp(j, 1) = sArr(i, 1)
      End If
      jC = .Item(iKey2) ' Thu tu du kieu
      tmp(jC, 2) = tmp(jC, 2) + 1 'Dem du lieu
      
      tmp(0, 1) = j
      Res(iR, 3) = tmp 'Mang du lieu tung Lop
    Next i
  End With
 
  For i = 1 To k 'Xep thu tu
    tmp = Res(i, 3)
    sRow = tmp(0, 1)
    ReDim Arr(1 To sRow)
    For j = sRow To 1 Step -1
      t = tmp(j, 2)
      jC = 0
      For c = 1 To sRow
        If tmp(c, 2) >= t Then jC = jC + 1
      Next c
      For c = j + 1 To sRow
        If tmp(c, 2) = t Then jC = jC - 1
      Next c
      Arr(jC) = tmp(j, 1)
    Next j
    Res(i, 2) = Join(Arr, ",")
  Next i
  Sheets("Sheet1").Range("F2").Resize(k, 2) = Res
End Sub

 

[Ba Tê]

Em có một bài toán muốn xin được trợ gúp ạ, bài toán của em, em muốn sắp xếp giữ liệu từ bảng dữ liệu và lớp (cột A và cột B), bài toán của em muốn ra kết quả như ra cột G, trong đó ô kết quả được sắp xếp theo trình tự theo số lượng như (có 3 giá trị B, 2 giá trị C.......) từ lớn đến bé, thì được kết quả như cột G1 hoặc G2 ở các lớp khác nhau ạ. em xin cảm ơn các bác. file e có đính kèm để dưới ạ. Năm mới chúc các bác luôn mạnh khỏe và nhiều may mắn.
View attachment 254332

Bạn xem file.....................

 

[TuPham86]

Hai cách của bác @HieuCD và bác @Ba Tê đều đúng ý của em cả, e đều sử dụng được cả hai ạ. đúng là còn phải học hỏi các bác nhiều ạ. em cảm ơn hai bác nhiều. Năm mới chúc 2 bác sức khỏe và thành công ạ.

Bài đã được tự động gộp: 21/2/21

Chưa đúng ý bạn lắm, tham khảo xem nha:

Sub ThongKeGiaiTheoLop()
Dim Rws As Long, J As Integer, Dem As Integer, W As Byte
Dim MyAdd As String, Tmp As String
Dim Rng As Range, sRng As Range
Const Col As Byte = 2

Rws = [B2].CurrentRegion.Rows.Count
ReDim Arr(1 To 1 + Rws, 1 To 3)
Set Rng = [A2].Resize(Rws):        [D5].Resize(26, 3).Value = Space(0)
Arr(1, 1) = "Du Liêu":             Arr(1, 2) = "Lóp 6A"
Arr(1, 3) = "Lóp 6B":                  W = 1
For J = 1 To 26
    Tmp = Chr(64 + J)
    Set sRng = Rng.Find(Tmp, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        W = W + 1:                  MyAdd = sRng.Address
        Arr(W, 1) = Tmp
        Do
            If sRng.Offset(, 1).Value = "6a" Then
                Arr(W, 2) = Arr(W, 2) + 1
            ElseIf sRng.Offset(, 1).Value = "6b" Then
                Arr(W, 3) = 1 + Arr(W, 3)
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
Next J
[D5].Resize(W, 3).Value = Arr()
End Sub

Đúng là chưa được với ý của em lắm, nhưng em cũng cảm ơn bác đã quan tâm đến bài của e. cảm ơn bác nhé. Chúc bác nhiều sức khỏe.