Hỗ trợ thống kê thay cho công thức

[Tình nghĩa giang hồ]

Chào anh chị em có trường hợp này nhờ anh chị hỗ trợ giúp em.
Em có rất nhiều sheet như file đính kèm.
Dữ liệu chính của em nằm ở cột D.

Em xin mô tả cách làm thủ công.
Đầu tiên em copy (D4 : D& dòng cuối của cột D) ra 1 cột khác sau đó em Remove Dulicates cột này. Tiếp theo em Sort A to Z
Sau đó em copy và Paste Tranpose vào F3.
Ở F4 thì em dùng công thức COUNTIF để đếm dữ liệu.
=COUNTIF($D$4:$D$211,F3)
Sau đó em kéo công thức F4 sang Q4
Đây là tất cả quá trình thủ công của em.

Vậy với cách làm thủ công này mình chuyển sang VBA viết theo dạng mảng thì viết thế nào anh chị.
Nhờ anh chị hỗ trợ giúp em trường hợp này.
Em cảm ơn.

 

[SA_DQ]

. . .
Sau đó em copy và Paste Tranpose vào F3.
. . . . .

Mà sao bạn phải Tranpose chi cho tốn thêm điện vậy nhỉ?

 

[Tình nghĩa giang hồ]

Mà sao bạn phải Tranpose chi cho tốn thêm điện vậy nhỉ?

Cái này do em thích nhìn ngang, em cũng không biết nhìn ngang hay nhìn dọc thì tốt hơn.
Kiểu thuận mắt thôi bác SA. Giống như kiểu thuận tay trái với tay phải vậy.
Ngang hay Dọc cũng được bác.

 

[VetMini]

Trời. Ngang dọc mà ví với tay trái tay phải.
Con người có tay trái tay phải cân bằng nhau.
Bảng tính có hàng dọc dùng để ghi phát sinh. Hàng ngang dùng để ghi tính chất. Hai nhiệm vụ hỗ tương nhau nhưng hoàn toàn khác biệt.
Một trăm con bò ghi thành 100 dòng. Tuổi tác, giống bò, màu sắc, cân nặng ghi thành 4 cột.
Khi các dòng có thể tổng hợp thì người ta cross-tab những tổng hợp thành cột (còn gọi là pivot).

 

[Maika8008]

Bài toán vẫn chưa có lời giải.

 

[VetMini]

Bài toán vẫn chưa có lời giải.

Tôi đã gợi ý cho từ khóa "Pivot".
Nếu cần thì tôi cho thêm từ khóa nữa: Data Model

 

[Tình nghĩa giang hồ]

Tôi đã gợi ý cho từ khóa "Pivot".
Nếu cần thì tôi cho thêm từ khóa nữa: Data Model

Bài này em muốn dùng VBA cơ.
Với câu hỏi của em đưa ra rất là rõ ràng.
Với sự rõ ràng của câu hỏi đó, em dùng chat GPT rồi chỉnh sửa lại vẫn ngon lành.
Nhưng mà thật sự code GPT em thấy có 1 sự thua kém 1 bậc so với code GPE anh.
Chứ bài này em mới nhờ GPT giải dùm cũng tạm ổn.

Sub ProcessDataWithoutFormula()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim uniqueDataRange As Range
    Dim outputColumn As Range
    Dim countData() As Variant
    Dim i As Long
  
    ' Đặt ws là Sheet1
    Set ws = ThisWorkbook.Sheets("Sheet1")
  
    ' Xác định dòng cuối của cột D
    lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
  
    ' Xác định vùng dữ liệu
    Set dataRange = ws.Range("D4:D" & lastRow)
  
    ' Copy dữ liệu vào mảng
    countData = dataRange.Value
  
    ' Tạo một Collection để lưu trữ dữ liệu duy nhất
    Dim uniqueValues As New Collection
  
    ' Lặp qua mảng để lọc ra dữ liệu duy nhất
    On Error Resume Next
    For i = LBound(countData, 1) To UBound(countData, 1)
        uniqueValues.Add countData(i, 1), CStr(countData(i, 1))
    Next i
    On Error GoTo 0
  
    ' Chuyển dữ liệu duy nhất từ Collection vào một mảng mới
    Dim uniqueArray() As Variant
    ReDim uniqueArray(1 To uniqueValues.Count, 1 To 1)
  
    For i = 1 To uniqueValues.Count
        uniqueArray(i, 1) = uniqueValues(i)
    Next i
  
    ' Paste dữ liệu duy nhất vào cột F
    Set uniqueDataRange = ws.Range("F4").Resize(UBound(uniqueArray, 1), 1)
    uniqueDataRange.Value = uniqueArray
  
    ' Lặp lại và đếm số lượng xuất hiện của mỗi giá trị
    For i = 1 To uniqueValues.Count
        ws.Cells(3 + i, 7).Value = Application.CountIf(dataRange, uniqueArray(i, 1))
    Next i
  
    ' Xóa dữ liệu của Collection
    Set uniqueValues = Nothing
  
    ' Xóa dữ liệu của mảng
    Erase countData
End Sub

 

[VetMini]

...
Nhưng mà thật sự code GPT em thấy có 1 sự thua kém 1 bậc so với code GPE anh.
Chứ bài này em đã nhờ GPT giải xong rồi
...

Bài này quan trọng ở chỗ nào mà phải so sánh hơn/thua.
Phí thì giờ vô ích. Để não học những công cụ mới của Excel có phải thực dụng hơn không?

Vả lại, ba cái AI chúng cải tiến liên tục. Hỏi đi hỏi lại vài lần sẽ được vài giải pháp khác. Lúc ấy tha hồ chọn cái "hơn".

Chú thích về chỗ bôi đậm:
Thua kém là nhận xét cá nhân của bạn. Chứ tôi đâu có thấy vậy.
Bản thân tôi thấy nó viết rất rõ ràng, so về hình thức, cấu trúc thì hơn hẳn GPE.

 

[CHAOQUAY]

Chạy thử code dưới đây

Option Explicit

Sub loc()
Dim Nguon
Dim Ma
Dim SL
Dim Tam
Dim KQ
Dim Spt
Dim i, j, k

Nguon = Sheet1.Range("A3").CurrentRegion
ReDim Ma(1000 To 9999)
ReDim SL(1000 To 9999)

For i = 2 To UBound(Nguon)
    Tam = Split(Nguon(i, 4), ",")
    k = 0
    For j = 0 To UBound(Tam)
        k = k * 10 + CInt(Tam(j)) / 1000
    Next j
    If UBound(Tam) < 3 Then
        k = k * (10 ^ (3 - UBound(Tam)))
    End If
    
    If SL(k) = 0 Then Spt = Spt + 1
    Ma(k) = Nguon(i, 4)
    SL(k) = SL(k) + 1
Next i

ReDim KQ(1 To 2, 1 To Spt)
k = 0
For j = 1000 To 9999
    If SL(j) > 0 Then
        k = k + 1
        KQ(1, k) = Ma(j)
        KQ(2, k) = SL(j)
    End If
    If k = Spt Then Exit For
Next j

With Sheet1
    .Range("F6").Resize(2, Spt) = KQ
End With
End Sub

 

[Tình nghĩa giang hồ]

Chạy thử code dưới đây

Option Explicit

Sub loc()
Dim Nguon
Dim Ma
Dim SL
Dim Tam
Dim KQ
Dim Spt
Dim i, j, k

Nguon = Sheet1.Range("A3").CurrentRegion
ReDim Ma(1000 To 9999)
ReDim SL(1000 To 9999)

For i = 2 To UBound(Nguon)
    Tam = Split(Nguon(i, 4), ",")
    k = 0
    For j = 0 To UBound(Tam)
        k = k * 10 + CInt(Tam(j)) / 1000
    Next j
    If UBound(Tam) < 3 Then
        k = k * (10 ^ (3 - UBound(Tam)))
    End If
   
    If SL(k) = 0 Then Spt = Spt + 1
    Ma(k) = Nguon(i, 4)
    SL(k) = SL(k) + 1
Next i

ReDim KQ(1 To 2, 1 To Spt)
k = 0
For j = 1000 To 9999
    If SL(j) > 0 Then
        k = k + 1
        KQ(1, k) = Ma(j)
        KQ(2, k) = SL(j)
    End If
    If k = Spt Then Exit For
Next j

With Sheet1
    .Range("F6").Resize(2, Spt) = KQ
End With
End Sub

Dạ em cảm ơn bác ChaoQuay.
Lâu lắm rồi mới thấy bác lại, cũng một thời gian rồi ạ.

 

[HieuCD]

Góp vui . . .

Sub ABC()
  Dim ws As Worksheet, arr(), res(), dic As Object
  Dim sR, i&, k&, j&
 
  Set dic = CreateObject("scripting.dictionary")
  Set ws = Sheets("Sheet1")
  arr = ws.Range("D4", ws.Range("D" & Rows.Count).End(xlUp)).Value
  sR = UBound(arr)
  ReDim res(1 To 2, 1 To sR)
  For i = 1 To sR
    If dic.exists(arr(i, 1)) = False Then
      k = k + 1
      dic.Add arr(i, 1), k
      res(1, k) = arr(i, 1)
      res(2, k) = 1
    Else
      j = dic(arr(i, 1))
      res(2, j) = res(2, j) + 1
    End If
  Next i
  j = ws.Range("AAA3").End(xlToLeft).Column
  If j > 6 Then ws.Range("F3", ws.Cells(4, j)).Clear
  ws.Range("F3").Resize(, k).NumberFormat = "@"
  ws.Range("F3").Resize(2, k) = res
  ws.Range("F3").Resize(2, k).Sort ws.Range("F3"), 1, Orientation:=xlLeftToRight
  ws.Range("F3").Resize(2, k).Borders.LineStyle = 1
End Sub

 

[VetMini]

Bài này em muốn dùng VBA cơ.
...

Bài #6 là tôi trả lời cho tác giả bài #5.
Với trường hợp của bạn thì tôi đã biết rõ. Bạn chỉ lưu tâm đến việc trình bày dữ liệu chứ không có một chút xíu ý niệm gì về phân tích dữ liệu.
Mục đích của bạn là code kiếc trông cho xịn chứ không phải làm chủ dữ liệu.