Nhờ giúp code lọc trùng, sắp xếp và tính tổng (6 người xem)

tommynguyen · 23/1/15

Xin chào các anh chị em.
Em đang vận hành 1 cửa hàng có rất nhiều mặt hàng, nhiều lần nhập hàng rất hay trùng tên mặt hàng
Em muốn nhờ các anh chị giúp em code để lọc trùng, sắp xếp lại cột tên và tính tổng các giá trị số lượng
Thêm nữa, Sheet KHO em muốn tìm kiếm từ danh sách ở trên các mặt hàng có chứa từ gõ ở ô C2
Ví dụ:
Tại ô C2 gõ IP5 thì hiển thị các hàng Tên có chứa từ IP5 như: bao da IP5, ốp lưng IP5, viền IP5...
Tại ô C2 gõ ốp thì hiển thị các hàng Tên có chứa từ ốp như: ốp lưng, ốp viền....
File em có gởi kèm, nhờ các anh chị giúp em viết VBA hoặc công thức để thực hiện việc trên. Dữ liệu em có khoảng 1000 dòng, máy chạy khá chậm.
Em xin cám ơn rất nhiều ạ!

comet_1701 · 23/1/15

tommynguyen đã viết:
Xin chào các anh chị em.
Em đang vận hành 1 cửa hàng có rất nhiều mặt hàng, nhiều lần nhập hàng rất hay trùng tên mặt hàng
Em muốn nhờ các anh chị giúp em code để lọc trùng, sắp xếp lại cột tên và tính tổng các giá trị số lượng
File em có gởi kèm, nhờ các anh chị giúp em viết VBA hoặc công thức để thực hiện việc trên. Dữ liệu em có khoảng 1000 dòng, máy chạy khá chậm.
Em xin cám ơn rất nhiều ạ!

Mã:

Sub Dic()
Dim Sarr, KQ, i&, k&
With Sheet1
    Sarr = .Range(.[B3], .[B65000].End(3)).Resize(, 3).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not .exists(Sarr(i, 2)) Then
            k = k + 1
            .Add Sarr(i, 2), k
            For j = 1 To 3
                KQ(k, j) = Sarr(i, j)
            Next
        Else
            KQ(.Item(Sarr(i, 2)), 3) = KQ(.Item(Sarr(i, 2)), 3) + Sarr(i, 3)
        End If
    Next
End With


With Sheets("QLBanHang")
    .[B6:D65000].ClearContents
    If k Then
        .[B6].Resize(UBound(Sarr, 1), 3).Value = KQ
        .[B6].Resize(UBound(Sarr, 1), 3).Sort key1:=.[B6]
    End If
End With
End Sub

Mình làm tạm 3 cột thôi, vì file của bạn nhiều cột quá, ngại ghê mà đang bận quá, còn code chắc là ok

tommynguyen · 23/1/15

Cảm ơn comet_1701 nhiều
Code chạy rất nhanh, chính xác, nếu có sắp xếp nữa thì tuyệt
Với cả dòng STT, Tên, Số lượng đang bị đẩy xuống hàng cuối cùng thì phải

comet_1701 · 23/1/15

tommynguyen đã viết:
Cảm ơn comet_1701 nhiều
Code chạy rất nhanh, chính xác, nếu có sắp xếp nữa thì tuyệt
Với cả dòng STT, Tên, Số lượng đang bị đẩy xuống hàng cuối cùng thì phải

Mã:

Sub Dic()
Dim Sarr, KQ, i&, k&
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(3)).Resize(, 3).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 3)


With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not .exists(Sarr(i, 2)) Then
            k = k + 1
            .Add Sarr(i, 2), k
            KQ(k, 1) = k
            For j = 2 To 3
                KQ(k, j) = Sarr(i, j)
            Next
        Else
            KQ(.Item(Sarr(i, 2)), 3) = KQ(.Item(Sarr(i, 2)), 3) + Sarr(i, 3)
        End If
    Next
End With




With Sheets("QLBanHang")
    .[B6:D65000].ClearContents
    If k Then
        .[B6].Resize(UBound(Sarr, 1), 3).Value = KQ
        .[B6].Resize(UBound(Sarr, 1), 3).Sort key1:=.[B6], order1:=xlAscending
    End If
End With
End Sub

Xin lỗi nhé, trên sửa B3 thành B6 là được

tommynguyen · 24/1/15

Bác comet_1701 ơi, nếu bây giờ em bỏ cột STT mà chỉ muốn lấy dữ liệu của 2 cột Tên và Số lượng thì code trên phải sửa như thế nào?
Cảm ơn bác

comet_1701 · 24/1/15

tommynguyen đã viết:
Bác comet_1701 ơi, nếu bây giờ em bỏ cột STT mà chỉ muốn lấy dữ liệu của 2 cột Tên và Số lượng thì code trên phải sửa như thế nào?
Cảm ơn bác

Mã:

Sub Dic()
Dim Sarr, KQ, i&, k&
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(3)).Resize(, 3).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 2)


With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not .exists(Sarr(i, 2)) Then
            k = k + 1
            .Add Sarr(i, 2), k
            KQ(k, 1) = Sarr(i, 2)
            KQ(k, 2) = Sarr(i, 3)
        Else
            KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)
        End If
    Next
End With


With Sheets("QLBanHang")
        .[A6:B65000].ClearContents
    If k Then
        .[A6].Resize(UBound(Sarr, 1), 2).Value = KQ
        .[A6].Resize(UBound(Sarr, 1), 2).Sort key1:=.[A6], order1:=xlAscending
    End If
End With
End Sub

ở sheet quản lý bán hàng bạn xóa 2 cột đầu đi nhé, rồi dùng code này. Chúc bạn thành công

tommynguyen · 26/1/15

Cảm ơn bác comet_1701, code của bác chạy rất nhanh và chính xác, nhưng lại chỉ được 3 cột.
Em dùng SUMIF cho các cột còn lại thì lại chạy rề rề.
Em muốn sửa lại code cho được tất cả các cột nhưng lại không có khả năng sửa code **~**

Thêm nữa, Sheet KHO em muốn tìm kiếm từ danh sách ở trên các mặt hàng có chứa từ gõ ở ô C2
Cao nhân giúp em vấy
Thanks.

comet_1701 · 26/1/15

tommynguyen đã viết:
Cảm ơn bác comet_1701, code của bác chạy rất nhanh và chính xác, nhưng lại chỉ được 3 cột.
Em dùng SUMIF cho các cột còn lại thì lại chạy rề rề.
Em muốn sửa lại code cho được tất cả các cột nhưng lại không có khả năng sửa code
Thêm nữa, Sheet KHO em muốn tìm kiếm từ danh sách ở trên các mặt hàng có chứa từ gõ ở ô C2
Cao nhân giúp em vấy
Thanks.

Mã:

Sub Dic()
Dim Sarr, KQ, i As Long, k As Long
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(xlUp)).Resize(, 97).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 92)




With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not .exists(Sarr(i, 2)) Then
            k = k + 1
            
            .Add Sarr(i, 2), k
            KQ(k, 1) = Sarr(i, 2)
            KQ(k, 2) = Sarr(i, 3)
            For j = 8 To UBound(Sarr, 2)
                KQ(k, j - 5) = Sarr(i, j)
            Next
        Else
            KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)
            KQ(.Item(Sarr(i, 2)), j - 5) = KQ(.Item(Sarr(i, 2)), j - 5) + Sarr(i, j)
        End If
    Next
End With




With Sheets("QLBanHang")
        .[A6:CN65000].ClearContents
    If k Then
        .[A6].Resize(k - 1, 92).Value = KQ
        .[A6].Resize(k - 1, 92).Sort key1:=.[A6], order1:=xlAscending
    End If
End With
End Sub

Mình thử đoạn này thì báo tràn rồi, giống bài này thì phải
http://www.giaiphapexcel.com/forum/...e-VBA-ghép-nối-và-thống-kê-giữa-2-sheet/page4
Bạn đợi anh em khác nhé

tommynguyen · 26/1/15

Cảm ơn bác comet_1701
Bác giúp em tìm kiếm ở sheet KHO với

comet_1701 · 26/1/15

tommynguyen đã viết:
Cảm ơn bác comet_1701
Bác giúp em tìm kiếm ở sheet KHO với

chỉ tìm mã có IP thôi hả bạn hay thế nào

Mã:

Sub Dic()
Dim Sarr, KQ, i As Long, k As Long
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(xlUp)).Resize(, 3).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 3)


    For i = 1 To UBound(Sarr, 1)
        If Sarr(i, 2) Like "*IP5*" Then
            k = k + 1
            KQ(k, 1) = k
            KQ(k, 2) = Sarr(i, 2)
            KQ(k, 3) = Sarr(i, 3)
        End If
    Next
With Sheets("Kho")
        .[B9:F65000].ClearContents
    If k Then
        .[B9].Resize(k - 1, 3).Value = KQ
        .[B9].Resize(k - 1, 3).Sort key1:=.[C9], order1:=xlAscending
    End If
End With
End Sub

Mình đang trong giờ làm, bạn thử xem thế nào nhé, chua kịp te st

tommynguyen · 27/1/15

IP chỉ là giá trị nhập ngẫu nhiên tại ô C2 thôi, có thể nhập giá trị khác. Vậy đoạn If Sarr(i, 2) Like "*IP5*" chắc phải đổi lại đúng ko bác?

comet_1701 · 27/1/15

tommynguyen đã viết:
IP chỉ là giá trị nhập ngẫu nhiên tại ô C2 thôi, có thể nhập giá trị khác. Vậy đoạn If Sarr(i, 2) Like "*IP5*" chắc phải đổi lại đúng ko bác?

Giá trị khác là giá trị nào, bạn nêu cụ thể trong topic đi, vì IP5 mã nhỏ nằm trong diễn giải, đừng để mọi người phải đoán đề bài nhiều, mà viết code 1 lần thôi

tommynguyen · 27/1/15

Ví dụ:
Tại ô C2 gõ IP5 thì hiển thị các hàng Tên có chứa từ IP5 như: bao da IP5, ốp lưng IP5, viền IP5...
Tại ô C2 gõ ốp thì hiển thị các hàng Tên có chứa từ ốp như: ốp lưng, ốp viền....

comet_1701 · 27/1/15

tommynguyen đã viết:
Ví dụ:
Tại ô C2 gõ IP5 thì hiển thị các hàng Tên có chứa từ IP5 như: bao da IP5, ốp lưng IP5, viền IP5...
Tại ô C2 gõ ốp thì hiển thị các hàng Tên có chứa từ ốp như: ốp lưng, ốp viền....

PHP:

Sub Dic()
Dim Sarr, KQ, i As Long, k As Long, TMP
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(xlUp)).Resize(, 3).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 3)
TMP = Sheets("Kho").Range("C2").Value
    For i = 1 To UBound(Sarr, 1)
        If InStr(Sarr(i, 2), TMP) <> 0 Then
            k = k + 1
            KQ(k, 1) = k
            KQ(k, 2) = Sarr(i, 2)
            KQ(k, 3) = Sarr(i, 3)
        End If
    Next
With Sheets("Kho")
        .[B9:D65000].ClearContents
    If k Then
        .[B9].Resize(k, 3).Value = KQ
    End If
End With
End Sub

Bạn thử đoạn này xem sao

tommynguyen · 27/1/15

Code có phân biệt chữ hoa chữ thường hả bác?

Ba Tê · 27/1/15

tommynguyen đã viết:
Xin chào các anh chị em.
Em đang vận hành 1 cửa hàng có rất nhiều mặt hàng, nhiều lần nhập hàng rất hay trùng tên mặt hàng
Em muốn nhờ các anh chị giúp em code để lọc trùng, sắp xếp lại cột tên và tính tổng các giá trị số lượng
Thêm nữa, Sheet KHO em muốn tìm kiếm từ danh sách ở trên các mặt hàng có chứa từ gõ ở ô C2
Ví dụ:
Tại ô C2 gõ IP5 thì hiển thị các hàng Tên có chứa từ IP5 như: bao da IP5, ốp lưng IP5, viền IP5...
Tại ô C2 gõ ốp thì hiển thị các hàng Tên có chứa từ ốp như: ốp lưng, ốp viền....
File em có gởi kèm, nhờ các anh chị giúp em viết VBA hoặc công thức để thực hiện việc trên. Dữ liệu em có khoảng 1000 dòng, máy chạy khá chậm.
Em xin cám ơn rất nhiều ạ!

Tạo mẫu dữ liệu kiểu này thì khi nhập, xuất một mặt hàng nào đó, dò tìm ngang dọc hơi bị oải à nghe.

comet_1701 · 27/1/15

tommynguyen đã viết:
Code có phân biệt chữ hoa chữ thường hả bác?

Thêm ucase như thầy Bate bạn nhá, Được thầy vào cái xong hết rồi nhá. Nhất bạn đó --=0

. Những lúc mình đang phải làm bạn mới post bài lên, nhiều lúc làm hơi vội có sai sót, thông cảm nhá

comet_1701 · 27/1/15

tommynguyen đã viết:
Code có phân biệt chữ hoa chữ thường hả bác?

PHP:

Sub Dic()
Dim Sarr, KQ, i As Long, k As Long, TMP As String
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(xlUp)).Resize(, 3).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 3)
With Sheets("Kho")
    TMP = UCase(.[C2])
    For i = 1 To UBound(Sarr, 1)
        If UCase(Sarr(i, 2)) Like "*" & TMP & "*" Then
            k = k + 1
            KQ(k, 1) = k
            KQ(k, 2) = Sarr(i, 2)
            KQ(k, 3) = Sarr(i, 3)
        End If
    Next
        .[B9:D65000].ClearContents
    If k Then
        .[B9].Resize(k, 3).Value = KQ
        .[C9].Resize(k, 2).Sort Key1:=.[C9]
    End If
End With
End Sub

Đây là cách của Thầy nhé
Ở sheet Kho bạn thêm sự kiện này vào (kích đúp sheet Kho khi mở Alt+F11)
Lúc đầu định thêm cho bạn nhưng phải đi làm, Thầy làm cho hết roài

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" Then LOC_
End Sub

Mục đích của sự kiện này là khi bạn thay mã ở C2 thì nó tự động lọc ra luôn, không cần mỗi lần chọn một ma lại chạy code nhé

comet_1701 · 27/1/15

PHP:

Sub Dic()
Dim Sarr, KQ, i As Long, k As Long, j
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(xlUp)).Resize(, 97).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 92)


With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not .exists(Sarr(i, 2)) Then
            k = k + 1
            
            .Add Sarr(i, 2), k
            KQ(k, 1) = Sarr(i, 2)
            KQ(k, 2) = Sarr(i, 3)
            For j = 8 To UBound(Sarr, 2)
                KQ(k, j - 5) = Sarr(i, j)
            Next
        Else
            KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)
            For j = 8 To UBound(Sarr, 2)
            KQ(.Item(Sarr(i, 2)), j - 5) = KQ(.Item(Sarr(i, 2)), j - 5) + Sarr(i, j)
            Next
        End If
    Next
End With


With Sheets("QLBanHang")
        .[A6:CN65000].ClearContents
    If k Then
        .[A6].Resize(k , 92).Value = KQ
        .[A6].Resize(k , 92).Sort key1:=.[A6], order1:=xlAscending
    End If
End With
End Sub

Ỏ bài 8 nếu sửa thành
For j = 8 To 90 thì lại được
nếu để như cũ thì báo tràn giống trường hợp anh Dhn46 trước đây được bác Vodoi giải quyết
For j = 8 To 90 nếu thay bằng ubound(sarr,2) vẫn ok, Xin lỗi em nhầm. Trường hợp của anh Ninh là 256 cột mới out
Cảm ơn Thầy Bate, nhìn code của thấy em phát hiện được cái sai của em

Ba Tê · 27/1/15

comet_1701 đã viết:

PHP:

Sub Dic()
Dim Sarr, KQ, i As Long, k As Long, j
With Sheet1
    Sarr = .Range(.[B6], .[B65000].End(xlUp)).Resize(, 97).Value2
End With
ReDim KQ(1 To UBound(Sarr, 1), 1 To 92)


With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not .exists(Sarr(i, 2)) Then
            k = k + 1
            
            .Add Sarr(i, 2), k
            KQ(k, 1) = Sarr(i, 2)
            KQ(k, 2) = Sarr(i, 3)
            For j = 8 To 90
                KQ(k, j - 5) = Sarr(i, j)
            Next
        Else
            For j = 8 To 90
            KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)
            KQ(.Item(Sarr(i, 2)), j - 5) = KQ(.Item(Sarr(i, 2)), j - 5) + Sarr(i, j)
            Next
        End If
    Next
End With


With Sheets("QLBanHang")
        .[A6:CN65000].ClearContents
    If k Then
        .[A6].Resize(k - 1, 92).Value = KQ
        .[A6].Resize(k - 1, 92).Sort key1:=.[A6], order1:=xlAscending
    End If
End With
End Sub

Ỏ bài 8 nếu sửa thành
For j = 8 To 90 thì lại được
nếu để như cũ thì báo tràn giống trường hợp anh Dhn46 trước đây được bác Vodoi giải quyết
For j = 8 To 90 nếu thay bằng ubound(sarr,2) vẫn ok, Xin lỗi em nhầm. Trường hợp của anh Ninh là 256 cột mới out

Bài #8 bạn bị lỗi ở đây nè:

PHP:

Else
            KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)
            KQ(.Item(Sarr(i, 2)), j - 5) = KQ(.Item(Sarr(i, 2)), j - 5) + Sarr(i, j)
        End If

j lúc này không nằm trong vòng For nên j =0, j-5 là số âm ---> Lỗi mảng KQ()
Bài kế trên

PHP:

For j = 8 To 90
            KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)
            KQ(.Item(Sarr(i, 2)), j - 5) = KQ(.Item(Sarr(i, 2)), j - 5) + Sarr(i, j)
            Next

Dòng

PHP:

KQ(.Item(Sarr(i, 2)), 2) = KQ(.Item(Sarr(i, 2)), 2) + Sarr(i, 3)

Nằm trong vòng For j làm gì?

Nhờ giúp code lọc trùng, sắp xếp và tính tổng (6 người xem)

Người dùng đang xem chủ đề này

Thành viên mới

File đính kèm

Thành viên tiêu biểu

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Cạo Rồi Khỏi Gội

File đính kèm

Thành viên tiêu biểu

Thành viên tiêu biểu

Thành viên tiêu biểu

Cạo Rồi Khỏi Gội

Đếm ngược thời gian