Tự động lập danh sách và đếm theo tên

[lanp900]

Chào các bác, em đang vướng vấn đề này nhờ các bác tư vấn hoặc có giải pháp giúp cho. Trong mớ hỗn độn em cần lập ra danh sách không trùng nhau sau đó thống kê SL mỗi loại. Xin gửi các bác file đính kèm để cho cụ thể. Cám ơn các bác.

 

[ndu96081631]

Chào các bác, em đang vướng vấn đề này nhờ các bác tư vấn hoặc có giải pháp giúp cho. Trong mớ hỗn độn em cần lập ra danh sách không trùng nhau sau đó thống kê SL mỗi loại. Xin gửi các bác file đính kèm để cho cụ thể. Cám ơn các bác.

Giá như dữ liệu của bạn là 1 CSDL chuẩn thì chỉ cần dùng công cụ có sẳn của Excel đã có thế tổng hợp được rồi... Đàng này, dữ liệu kỳ cục quá nên đành phải dùng code (dạng bài này đã được đăng mấy lần rồi)

Private Sub ConsolData(sRng As Range, Target As Range)
  Dim Clls As Range, TmpRng As Range, Tmp1 As String, Arr()
  Dim i As Long, j As Long, n As Long, Tmp2 As Long
  If sRng.Columns.Count < 2 Then Exit Sub
  On Error Resume Next
  Set TmpRng = sRng.Offset(, 1).Resize(, sRng.Columns.Count - 1)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To TmpRng.Rows.Count
      For j = 1 To TmpRng.Columns.Count
        Tmp1 = Trim(TmpRng(i, j))
        Tmp2 = sRng(i, 1)
        If Tmp1 <> "" Then
          If Not .Exists(Tmp1) Then
            n = n + 1
            .Add Tmp1, n
            ReDim Preserve Arr(1 To 2, 1 To n)
            Arr(1, n) = Tmp1: Arr(2, n) = Tmp2
          Else
            Arr(2, .Item(Tmp1)) = Arr(2, .Item(Tmp1)) + Tmp2
          End If
        End If
      Next j
    Next i
    Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr)
  End With
End Sub

Sub Main()
  On Error Resume Next
  ConsolData Application.InputBox("Chon vùng", Type:=8), [K1]
End Sub

 

[lanp900]

Xin cảm ơn bác, về căn bản vấn đề của em đã được giải quyết. Em cần thời gian để nắm được giải pháp bác vừa giúp để ứng dụng. Một lần nữa nhiệt liệt cám ơn!

 

[concogia]

Thấy chạy code này cũng ổn

Public Sub hoaqua()
    Dim d As Object, Vung As Range, Cll As Range, I As Integer, Tam, SoL, Wf
    Set Vung = [a2].CurrentRegion: Set Wf = Application.WorksheetFunction
    Set SoL = Vung.Offset(1).Resize(Vung.Rows.Count - 1, 1):    Set d = CreateObject("scripting.dictionary")
    [a20].CurrentRegion.Clear
           For Each Cll In Vung.Offset(1, 1).Resize(Vung.Rows.Count, Vung.Columns.Count - 1)
            On Error Resume Next
                If Cll <> "" Then
                For I = 1 To Vung.Columns.Count - 1
                    Tam = Tam + Wf.SumIf(SoL.Offset(, I), Cll, SoL)
                Next
                    d.Add Cll.Value, Tam
                End If
                Tam = 0
           Next
          [a20].Resize(d.Count) = Wf.Transpose(d.keys)
          [b20].Resize(d.Count) = Wf.Transpose(d.items)
End Sub

Xuất kết quả ở cell A20