Chỉnh sửa doạn code: Lọc dữ liệu sang sheet khac theo điều kiện ko trùng nhau và sắp xếp theo thứ tự tăng dần (1 người xem)

[d.dinhtam]

Gửi bạn, trong file mẩu của mình có 2sheet : "NKGN" và "BCTK" mình muốn lấy dữ liệu cột : mã bao,mã hàng, loại vàng từ sheet "NKGN" sang sheet "BCTK" và điều kiện lọc là cột A của sheet "NKGN" những mã trùng lặp thì lấy 1 lần. Cột mã bao lấy sang sheet "BCTK" sắp xếp theo thứ tự tăng dần và theo nhóm loại vàng. Mong nhận được hướng dẫn của các bạn.

Sub rep()

Dim i As Long, j As Long, K As Long

Dim K1 As Long

Dim ArrNguon()

Dim ArrDich()

Dim Arr_MH()

Dim Dongcuoi As Long

Dim Dic_MH As Object



Dongcuoi = Sheet10.Range("A60000").End(xlUp).Row

ArrNguon = Sheet10.Range("A6:E" & Dongcuoi)

ReDim Arr_MH(1 To UBound(ArrNguon, 1), 1 To 4)

ReDim Arr_Ngay(1 To 1, 1 To UBound(ArrNguon, 1))



Sheet11.Range("a9:d60000").ClearContents



Set Dic_MH = CreateObject("Scripting.Dictionary")



For i = 1 To UBound(ArrNguon, 1)

If Trim(ArrNguon(i, 1)) <> "" Then 'Trim loc bo khoang trong, cot 1 Ma'

If Not Dic_MH.Exists(ArrNguon(i, 1)) Then

K = K + 1

Dic_MH.Add ArrNguon(i, 1), K

Arr_MH(K, 1) = K

Arr_MH(K, 2) = ArrNguon(i, 3)

Arr_MH(K, 3) = ArrNguon(i, 4)

Arr_MH(K, 4) = ArrNguon(i, 5)



End If

End If

Next

Sheet11.Range("B9").Resize(K, 3).NumberFormat = "@"

Sheet11.Range("A9").Resize(K, 4) = Arr_MH



End Sub

 

[Let'GâuGâu]

làm bằng tay chắc con nhanh hơn
- remove duplicate cột A
- Sort theo cot E
-nếu sắp xếp theo mã bao nữa thì cột B
===
viết code mà sort chắc hơi phê...
- chắc làm 3 cái dic và 3 mảng kết quả, 1 cái cho 10k,14,18k
lúc chép xuống sheet thì cũng chép theo thứ tự đó
nếu sort thêm cột B mã bao thì...hihihi

 

[befaint]

3 cái dic

Cái gì mà ghê gớm vậy. 3 cái "đíc" to thì kinh khủng quá. Nhưng mà liên quan tới vàng thì chắc không phải nghĩ, chỉ cần một "cục" là xong.

 

[Ba Tê]

Gửi bạn, trong file mẩu của mình có 2sheet : "NKGN" và "BCTK" mình muốn lấy dữ liệu cột : mã bao,mã hàng, loại vàng từ sheet "NKGN" sang sheet "BCTK" và điều kiện lọc là cột A của sheet "NKGN" những mã trùng lặp thì lấy 1 lần. Cột mã bao lấy sang sheet "BCTK" sắp xếp theo thứ tự tăng dần và theo nhóm loại vàng. Mong nhận được hướng dẫn của các bạn.

Bạn đưa cái Sub lên là ý gì, chưa đúng chỗ nào? Nếu không xài được thì đưa lên đọc cho "mõi mắt" chơi?
Bạn chạy thử Sub này xem có đạt yêu cầu không?
Cột loại vàng không biết Sort kiểu nào theo cột Mã bao.

Sub GPE()
Dim sArr(), I As Long, J As Long, K As Long, R As Long, Rws As Long, Tem As String
sArr = Sheets("NKGN").Range("C6", Sheets("NKGN").Range("C6").End(xlDown)).Resize(, 11).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 10)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 3)
        If Not .Exists(Tem) Then
            K = K + 1
            .Item(Tem) = K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 1)
            dArr(K, 3) = sArr(I, 2)
            dArr(K, 4) = sArr(I, 3)
            dArr(K, 5) = sArr(I, 8)
            dArr(K, 6) = sArr(I, 9)
        Else
            Rws = .Item(Tem)
            dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 8)
            dArr(Rws, 6) = dArr(Rws, 6) + sArr(I, 9)
        End If
    Next I
End With
With Sheets("BCTK")
    .Range("A9:F1000").ClearContents
    .Range("A9:F9").Resize(K) = dArr
    .Range("B9:F9").Resize(K).Sort Key1:=.Range("B9")
End With
End Sub

 

[d.dinhtam]

Sub GPE() Dim sArr(), I As Long, J As Long, K As Long, R As Long, Rws As Long, Tem As String sArr = Sheets("NKGN").Range("C6", Sheets("NKGN").Range("C6").End(xlDown)).Resize(, 11).Value R = UBound(sArr) ReDim dArr(1 To R, 1 To 10) With CreateObject("Scripting.Dictionary") For I = 1 To R Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 3) If Not .Exists(Tem) Then K = K + 1 .Item(Tem) = K dArr(K, 1) = K dArr(K, 2) = sArr(I, 1) dArr(K, 3) = sArr(I, 2) dArr(K, 4) = sArr(I, 3) dArr(K, 5) = sArr(I, 8) dArr(K, 6) = sArr(I, 9) Else Rws = .Item(Tem) dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 8) dArr(Rws, 6) = dArr(Rws, 6) + sArr(I, 9) End If Next I End With With Sheets("BCTK") .Range("A9:F1000").ClearContents .Range("A9:F9").Resize(K) = dArr .Range("B9:F9").Resize(K).Sort Key1:=.Range("B9") End With End Sub

Bạn đưa cái Sub lên là ý gì, chưa đúng chỗ nào? Nếu không xài được thì đưa lên đọc cho "mõi mắt" chơi?
Bạn chạy thử Sub này xem có đạt yêu cầu không?
Cột loại vàng không biết Sort kiểu nào theo cột Mã bao.

Sub GPE()
Dim sArr(), I As Long, J As Long, K As Long, R As Long, Rws As Long, Tem As String
sArr = Sheets("NKGN").Range("C6", Sheets("NKGN").Range("C6").End(xlDown)).Resize(, 11).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 10)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 3)
        If Not .Exists(Tem) Then
            K = K + 1
            .Item(Tem) = K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 1)
            dArr(K, 3) = sArr(I, 2)
            dArr(K, 4) = sArr(I, 3)
            dArr(K, 5) = sArr(I, 8)
            dArr(K, 6) = sArr(I, 9)
        Else
            Rws = .Item(Tem)
            dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 8)
            dArr(Rws, 6) = dArr(Rws, 6) + sArr(I, 9)
        End If
    Next I
End With
With Sheets("BCTK")
    .Range("A9:F1000").ClearContents
    .Range("A9:F9").Resize(K) = dArr
    .Range("B9:F9").Resize(K).Sort Key1:=.Range("B9")
End With
End Sub

Chạy đoạn code của bạn gửi thì thứ tự mã bao được sắp xếp tăng dần nhưng dữ liệu lấy qua bị thiếu do bạn lọc dữ liệu cột C của Sheets("NKGN").

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

Chạy đoạn code của bạn gửi thì thứ tự mã bao được sắp xếp tăng dần nhưng dữ liệu lấy qua bị thiếu do bạn lọc dữ liệu cột C của Sheets("NKGN").

Đoạn code mình đưa lên là muốn nhờ ACE giúp mình chỉnh sữa bổ sung điều kiện sort theo thứ tự mã bao tăng dần.