Nhờ viết code tìm kiếm top 5 khách hàng có số lượng trả hàng nhiều nhất

Liên hệ QC
G

guitarnguyen1989

Thành viên chính thức
Tham gia
31/7/16
Bài viết
59
Được thích
7
Dear anh ,chị !

- Mình có một bảng dữ liệu hàng trả về của khách hàng khoảng 350.000 dòng ( sheet DATA ) , vấn đề cần giúp đỡ là :

* Thống kê top 5 khách hàng có số lượng hàng trả về nhiều nhất trong kỳ ( kỳ theo tháng và năm ).
* Sau khi thống kê , Copy dữ liệu thống kê được qua sheet báo cáo ( sheet Report)

P/s: Mình có dùng hàm sumifs hoặc pivot , để thống kê thì vẫn làm được , nhưng dữ liệu quá lớn làm file nặng .

Nhờ các anh chị có thể viết dùm một code để giải quyết vấn đề này . (Mình có gửi file đính kèm )


Thanks
 

File đính kèm

  • Tim top 5 khach hang.xlsx
    12.5 KB · Đọc: 3
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
guitarnguyen1989 đã viết:
Dear anh ,chị !

- Mình có một bảng dữ liệu hàng trả về của khách hàng khoảng 350.000 dòng ( sheet DATA ) , vấn đề cần giúp đỡ là :

* Thống kê top 5 khách hàng có số lượng hàng trả về nhiều nhất trong kỳ ( kỳ theo tháng và năm ).
* Sau khi thống kê , Copy dữ liệu thống kê được qua sheet báo cáo ( sheet Report)

P/s: Mình có dùng hàm sumifs hoặc pivot , để thống kê thì vẫn làm được , nhưng dữ liệu quá lớn làm file nặng .

Nhờ các anh chị có thể viết dùm một code để giải quyết vấn đề này . (Mình có gửi file đính kèm )


Cảm ơn
Nhấp chuột vào đây để mở rộng...
Trong truong hop co bang nhau thi sao nhi.
 
Upvote 0
Bạn thử xài hàm DMAX() xem sao; Tốc độ của nó cũng khấm khá lắm à nha.
 
Upvote 0
befaint đã viết:
Tiết mục đuổi chữ bắt nghĩa...
Theo tháng, theo năm thì trông mặt mũi nó dzư lào? Nhập điều kiện đó vào đâu?
Nhấp chuột vào đây để mở rộng...

****Tháng năm theo cột ngày trả
**** đều kiện nhập vào một cell bất kỳ , cell F1 : tháng ,cell G1 : Năm , thay đối giá trị thì code tự chạy .


Thanks tiết mục đuổi chim bắt bướm .... :D
 
Upvote 0
guitarnguyen1989 đã viết:
****Tháng năm theo cột ngày trả
**** đều kiện nhập vào một cell bất kỳ , cell F1 : tháng ,cell G1 : Năm , thay đối giá trị thì code tự chạy .


Cảm ơn tiết mục đuổi chim bắt bướm .... :D
Nhấp chuột vào đây để mở rộng...
Bạn chạy code này xem nhé.
Mã: 
Sub lay5thang()
    Dim arr, arr1, i As Long, j As Long, a As Long, tong As Double, dic As Object, olit As Object, lr As Long, ngaybd As Date, ngaykt As Date, dk As Long, olit1 As Object, c As Integer
    Set dic = CreateObject("scripting.dictionary")
      With Sheets("data")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 3 Then Exit Sub
         arr = .Range("A3:D" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 4)
      End With
      With Sheets("report")
      ngaybd = .Range("F1").Value
      ngaykt = .Range("H1").Value
         For i = 1 To UBound(arr, 1)
             If CLng(arr(i, 1)) >= CLng(ngaybd) And CLng(arr(i, 1)) <= CLng(ngaykt) Then
                 If Not dic.exists(arr(i, 2)) Then
                    a = a + 1
                    arr1(a, 1) = a
                    arr1(a, 2) = arr(i, 2)
                    arr1(a, 3) = arr(i, 3)
                    arr1(a, 4) = arr(i, 4)
                    dic.Add arr(i, 2), a
                 Else
                    b = dic.Item(arr(i, 2))
                    arr1(b, 4) = arr1(b, 4) + arr(i, 4)
                 End If
            End If
         Next i
  Set dic = Nothing
  Set olit = CreateObject("System.Collections.ArrayList")
         For i = 1 To a
             dk = arr1(i, 4)
             olit.Add dk
         Next i
  Set olit1 = olit.Clone
      olit.Sort
      ReDim arr(1 To 5, 1 To 4)
      For i = a - 1 To a - 5 Step -1
          c = c + 1
          b = olit1.InDexOf(olit(i), 0) + 1
          arr(c, 1) = c
          arr(c, 2) = arr1(b, 2)
          arr(c, 3) = arr1(b, 3)
          arr(c, 4) = arr1(b, 4)
     Next i
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A3:D" & lr).ClearContents
     .Range("A3:D7").Value = arr
    End With
End Sub
 

File đính kèm

  • Tim top 5 khach hang (1).xlsm
    23 KB · Đọc: 10
Upvote 0
BỊ LỖI , NHỜ BẠN XEM LẠI CẢM ƠN !!!
snow25 đã viết:
Bạn chạy code này xem nhé.
Mã: 
Sub lay5thang()
    Dim arr, arr1, i As Long, j As Long, a As Long, tong As Double, dic As Object, olit As Object, lr As Long, ngaybd As Date, ngaykt As Date, dk As Long, olit1 As Object, c As Integer
    Set dic = CreateObject("scripting.dictionary")
      With Sheets("data")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 3 Then Exit Sub
         arr = .Range("A3:D" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 4)
      End With
      With Sheets("report")
      ngaybd = .Range("F1").Value
      ngaykt = .Range("H1").Value
         For i = 1 To UBound(arr, 1)
             If CLng(arr(i, 1)) >= CLng(ngaybd) And CLng(arr(i, 1)) <= CLng(ngaykt) Then
                 If Not dic.exists(arr(i, 2)) Then
                    a = a + 1
                    arr1(a, 1) = a
                    arr1(a, 2) = arr(i, 2)
                    arr1(a, 3) = arr(i, 3)
                    arr1(a, 4) = arr(i, 4)
                    dic.Add arr(i, 2), a
                 Else
                    b = dic.Item(arr(i, 2))
                    arr1(b, 4) = arr1(b, 4) + arr(i, 4)
                 End If
            End If
         Next i
  Set dic = Nothing
  Set olit = CreateObject("System.Collections.ArrayList")
         For i = 1 To a
             dk = arr1(i, 4)
             olit.Add dk
         Next i
  Set olit1 = olit.Clone
      olit.Sort
      ReDim arr(1 To 5, 1 To 4)
      For i = a - 1 To a - 5 Step -1
          c = c + 1
          b = olit1.InDexOf(olit(i), 0) + 1
          arr(c, 1) = c
          arr(c, 2) = arr1(b, 2)
          arr(c, 3) = arr1(b, 3)
          arr(c, 4) = arr1(b, 4)
     Next i
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A3:D" & lr).ClearContents
     .Range("A3:D7").Value = arr
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
1552184144193.png
 
Upvote 0
guitarnguyen1989 đã viết:
****Tháng năm theo cột ngày trả
**** đều kiện nhập vào một cell bất kỳ , cell F1 : tháng ,cell G1 : Năm , thay đối giá trị thì code tự chạy .


Cảm ơn tiết mục đuổi chim bắt bướm .... :D
Nhấp chuột vào đây để mở rộng...
Nhập từ ngày, đến ngày là dễ nhất cho bạn, muốn bao nhiêu ngày tùy bạn.
 

File đính kèm

  • Tim top 5 khach hang.rar
    24.3 KB · Đọc: 19
Upvote 0
Ba Tê đã viết:
Nhập từ ngày, đến ngày là dễ nhất cho bạn, muốn bao nhiêu ngày tùy bạn.
Nhấp chuột vào đây để mở rộng...

Mã: 
 For I = 1 To R  ' xét từng dòng 
        If sArr(I, 1) >= fDate Then     ' nếu  dòng 1 , cột 1  >= ngày bắt đầu
            If sArr(I, 1) <= eDate Then   '  thì nếu dòng 1 , cột 1 <= ngày kết thúc 
                Txt = CStr(sArr(I, 2))     ' gán biến TXT =  ???? ( không hiểu)
                If Not Dic.Exists(Txt) Then    ' không hiểu 
                    K = K + 1                         ' cho K = K +1 
                    Dic.Item(Txt) = K               ' không hiểu
                    dArr(K, 1) = Txt               '?
                    dArr(K, 2) = sArr(I, 3) '? 
                    dArr(K, 3) = sArr(I, 4)  "  
                Else
                    Rws = Dic.Item(Txt)   '?
                    dArr(Rws, 3) = dArr(Rws, 3) + sArr(I, 4)     ' ???? 
                End If
            End If
        End If
    Next I

Anh Ba tê giải thích dùm mình đoạn này với ... chổ này mình không hiểu lắm
 
Upvote 0
guitarnguyen1989 đã viết:
Mình ghi nhầm tiêu đề : số lượng trả . mình đã update lại file
Nhấp chuột vào đây để mở rộng...
Lấy 5 khách hàng lớn nhất phải Sort dữ liệu
Nếu code chạy báo lỗi thì vào trang sau xem cách khai báo
https://www.giaiphapexcel.com/diendan/threads/bài-17-sortedlist.130129/
Mã: 
Sub GPE()
  Dim sArr(), fDay As Date, eDay As Date, i As Long
  Const sRow As Long = 5
 
  On Error Resume Next
  With Sheets("data")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A3:D" & i).Value
  End With
  With Sheets("report")
    fDay = .Range("G1").Value
    eDay = .Range("G2").Value
    If Err.Number <> 0 Then
      MsgBox ("Ngày nhap sai"): Err.Number = 0: Exit Sub
    End If
    .Range("A3:D3").Resize(sRow) = QuickSortSum(sArr, fDay, eDay, sRow)
  End With
End Sub
Private Function QuickSortSum(sArr As Variant, fDay As Date, eDay As Date, sRow) As Variant
  Dim sList As Object, dArr(), Res(), S, iKey
  Dim i As Long, k As Long, ik As Long, m As Long
 
  ReDim dArr(1 To UBound(sArr), 1 To 3)
  ReDim Res(1 To sRow, 1 To 4)
  Set sList = CreateObject("System.Collections.SortedList")
  For i = LBound(sArr) To UBound(sArr)
    If sArr(i, 1) >= fDay Then
      If sArr(i, 1) <= eDay Then
        iKey = CStr(sArr(i, 2))
        If Len(iKey) > 0 Then
          If Not sList.Contains(iKey) Then
            k = k + 1
            sList.Item(iKey) = k
            dArr(k, 1) = iKey: dArr(k, 2) = sArr(i, 3): dArr(k, 3) = sArr(i, 4)
          Else
            ik = sList.Item(iKey)
            dArr(ik, 3) = dArr(ik, 3) + sArr(i, 4)
          End If
        End If
      End If
    End If
  Next i
  sList.Clear
  For i = 1 To k
    iKey = dArr(i, 3)
    sList.Item(iKey) = sList.Item(iKey) & "," & i
  Next i
  k = 0
  For i = sList.Count - 1 To 0 Step -1
    S = Split(sList.GetByIndex(i), ",")
    For m = 1 To UBound(S)
      ik = CLng(S(m))
      k = k + 1
      Res(k, 1) = k: Res(k, 2) = dArr(ik, 1)
      Res(k, 3) = dArr(ik, 2): Res(k, 4) = dArr(ik, 3)
    Next m
    If k = 5 Then GoTo Thoat
  Next i
Thoat:
  Set sList = Nothing
  QuickSortSum = Res
End Function
 

File đính kèm

  • Tim top 5 khach hang (1).xlsm
    24.2 KB · Đọc: 17
Upvote 0
HieuCD đã viết:
Lấy 5 khách hàng lớn nhất phải Sort dữ liệu
Nếu code chạy báo lỗi thì vào trang sau xem cách khai báo
https://www.giaiphapexcel.com/diendan/threads/bài-17-sortedlist.130129/
Mã: 
Sub GPE()
  Dim sArr(), fDay As Date, eDay As Date, i As Long
  Const sRow As Long = 5

  On Error Resume Next
  With Sheets("data")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A3:D" & i).Value
  End With
  With Sheets("report")
    fDay = .Range("G1").Value
    eDay = .Range("G2").Value
    If Err.Number <> 0 Then
      MsgBox ("Ngày nhap sai"): Err.Number = 0: Exit Sub
    End If
    .Range("A3:D3").Resize(sRow) = QuickSortSum(sArr, fDay, eDay, sRow)
  End With
End Sub
Private Function QuickSortSum(sArr As Variant, fDay As Date, eDay As Date, sRow) As Variant
  Dim sList As Object, dArr(), Res(), S, iKey
  Dim i As Long, k As Long, ik As Long, m As Long

  ReDim dArr(1 To UBound(sArr), 1 To 3)
  ReDim Res(1 To sRow, 1 To 4)
  Set sList = CreateObject("System.Collections.SortedList")
  For i = LBound(sArr) To UBound(sArr)
    If sArr(i, 1) >= fDay Then
      If sArr(i, 1) <= eDay Then
        iKey = CStr(sArr(i, 2))
        If Len(iKey) > 0 Then
          If Not sList.Contains(iKey) Then
            k = k + 1
            sList.Item(iKey) = k
            dArr(k, 1) = iKey: dArr(k, 2) = sArr(i, 3): dArr(k, 3) = sArr(i, 4)
          Else
            ik = sList.Item(iKey)
            dArr(ik, 3) = dArr(ik, 3) + sArr(i, 4)
          End If
        End If
      End If
    End If
  Next i
  sList.Clear
  For i = 1 To k
    iKey = dArr(i, 3)
    sList.Item(iKey) = sList.Item(iKey) & "," & i
  Next i
  k = 0
  For i = sList.Count - 1 To 0 Step -1
    S = Split(sList.GetByIndex(i), ",")
    For m = 1 To UBound(S)
      ik = CLng(S(m))
      k = k + 1
      Res(k, 1) = k: Res(k, 2) = dArr(ik, 1)
      Res(k, 3) = dArr(ik, 2): Res(k, 4) = dArr(ik, 3)
    Next m
    If k = 5 Then GoTo Thoat
  Next i
Thoat:
  Set sList = Nothing
  QuickSortSum = Res
End Function
Nhấp chuột vào đây để mở rộng...
Cái này hay nhỉ anh.Vừa sắp xếp được lại còn lọc được nữa.
Mã: 
Set sList = CreateObject("System.Collections.SortedList")
 
Upvote 0
Đã biết Pivot thì cũng phải biết khi gặp dữ liệu nhiều, cho chúng vào data model và Power Pivot. Hàng triệu dòng cũng chả thấm.

Code VBA thì dùng ADO có lẽ là khoẻ nhất.
 
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

K
Set macro là disable nhưng file macro vẫn chạy !
Trả lời
1
Đọc
2
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
C
  • Question
Tạo schedule chạy code VBA
Trả lời
5
Đọc
184
castanea
C
Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
2
Trả lời
25
Đọc
418
Hoàng Tuấn 868
H
phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
10
Đọc
248
phammaihuong90
phammaihuong90
Nguyễn Duy Tuân
Phần mềm tạo QRcode cho thanh toán nhanh và cho chuỗi ký tự bất kỳ
    • Thích
    • Yêu thích
2
Trả lời
26
Đọc
984
Nguyễn Duy Tuân
Nguyễn Duy Tuân
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