Giúp code cộng dồn SL và Thành tiền khi trùng 2 cột

minhtuan55 · 3/4/19

Chào cả nhà GPE ! Em cần đoạn code cộng dồn SL và Thành tiền khi trùng điều kiện 2 cột. Em xin gửi ảnh minh họa. Mong mọi người giúp đở xin chân thành cảm ơn

LamNA · 3/4/19

minhtuan55 đã viết:
Chào cả nhà GPE ! Em cần đoạn code cộng dồn SL và Thành tiền khi trùng điều kiện 2 cột. Em xin gửi ảnh minh họa. Mong mọi người giúp đở xin chân thành cảm ơn
View attachment 214582

Dữ liệu chuẩn Pivot cho nhanh

leonguyenz · 4/4/19

Tham khảo Dictionary

Mã:

Sub Button1_Click()
Dim Dic As Object, sArr(), iR As Long, jR As Long, kR As Long, rArr(), Tmp As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
    sArr = .Range(.[B4], .[E65536].End(3)).Value
End With
ReDim rArr(1 To UBound(sArr), 1 To 4)
For iR = 1 To UBound(sArr)
    Tmp = sArr(iR, 1) & sArr(iR, 2)
    If Not Dic.Exists(Tmp) Then
        kR = kR + 1
        Dic.Add Tmp, kR
        For jR = 1 To 4
            rArr(kR, jR) = sArr(iR, jR)
        Next
    Else
        rArr(Dic.Item(Tmp), 3) = rArr(Dic.Item(Tmp), 3) + sArr(iR, 3)
        rArr(Dic.Item(Tmp), 4) = rArr(Dic.Item(Tmp), 4) + sArr(iR, 4)
    End If
Next
If kR Then
    Sheets("Sheet1").[G4:J10000].ClearContents
    Sheets("Sheet1").[G4].Resize(kR, 4) = rArr
End If
Set Dic = Nothing
End Sub

minhtuan55 · 4/4/19

leonguyenz đã viết:

Tham khảo Dictionary

Mã:

Sub Button1_Click()
Dim Dic As Object, sArr(), iR As Long, jR As Long, kR As Long, rArr(), Tmp As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
    sArr = .Range(.[B4], .[E65536].End(3)).Value
End With
ReDim rArr(1 To UBound(sArr), 1 To 4)
For iR = 1 To UBound(sArr)
    Tmp = sArr(iR, 1) & sArr(iR, 2)
    If Not Dic.Exists(Tmp) Then
        kR = kR + 1
        Dic.Add Tmp, kR
        For jR = 1 To 4
            rArr(kR, jR) = sArr(iR, jR)
        Next
    Else
        rArr(Dic.Item(Tmp), 3) = rArr(Dic.Item(Tmp), 3) + sArr(iR, 3)
        rArr(Dic.Item(Tmp), 4) = rArr(Dic.Item(Tmp), 4) + sArr(iR, 4)
    End If
Next
If kR Then
    Sheets("Sheet1").[G4:J10000].ClearContents
    Sheets("Sheet1").[G4].Resize(kR, 4) = rArr
End If
Set Dic = Nothing
End Sub

Code chạy quá chính xác. Em muốn nó không phân biệt chữ Hoa chử thường thì thêm UCASE vào đoạn này phải không anh
Tmp = UCase(sArr(iR, 1)) & UCase(sArr(iR, 2))
Thank anh nhiều. Chúc anh năm mới rực rỡ lên Mercedes hoặc BMW hoặc Porche Hoặc Audi Hoặc Mada6 như em cũng được rồi

minhtuan55 · 4/4/19

LamNA đã viết:
Dữ liệu chuẩn Pivot cho nhanh

Thanh anh nhiều . Cách của anh rất ok. Nhưng em không áp dụng Pivot cho File em được. Em chỉ thích sài COde thôi anh à

LamNA · 4/4/19

minhtuan55 đã viết:
Thanh anh nhiều . Cách của anh rất ok. Nhưng em không áp dụng Pivot cho File em được. Em chỉ thích sài COde thôi anh à

Vậy góp vui 1 đoạn chưa kiểm tra

Mã:

Sub Loc()
    Dim Dic As Object
    Dim i As Long, j As Long, k As Long
    Dim Tmp As String
    Dim Arr, dArr
    Application.ScreenUpdating = False
    Sheet1.Range("G4").Resize(1000, 4).ClearContents
    Arr = Range(Sheet1.[B4], Sheet1.[E6000].End(3)).Resize(, 4)
    ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
             Tmp = Arr(i, 2)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                For j = 1 To UBound(Arr, 2)
                    dArr(k, j) = Arr(i, j)
                Next j
            Else
            
                dArr(.Item(Tmp), 4) = dArr(.Item(Tmp), 4) + Arr(i, 4)
                dArr(.Item(Tmp), 3) = dArr(.Item(Tmp), 3) + Arr(i, 3)
            End If
        Next i
    End With
    Sheet1.Range("G4").Resize(k, UBound(Arr, 2)) = dArr
    Application.ScreenUpdating = True
End Sub

VetMini · 4/4/19

Cả hai code ở bài #3 và #6 đều theo thói quen quá cho nên không nhận ra rằng với loại này, cộng dồn thẳng trên một mảng tốt hơn.
1. Tiết kiệm được bộ nhớ cho 1 mảng (không hẳn quan trọng lắm)
2. Không phải chép lại dữ liệu key vào mảng thứ 2

Đính chính 05/04/2019:
Điểm 2 tôi nêu ra hôm trước không đúng. Vì bỏ bớt dòng cho nên các records chính bị đổi vị trí, và do vậy vẫn phải chép lại dữ liệu key vào mảng.

Hoàng Nhật Phương · 1/5/19

Xin chào tất cả mọi người,

2 đoạn code #3 và #6 đều chưa đúng ý tác giả thì phải. Nếu dữ liệu thêm 2 dòng 15,16 trong khung thì kết quả phải giống như bảng kết quả mong muốn ạ.

Oanh Thơ cũng chưa biết cách xử lý nên up lên để mong được mở mang thêm ạ.

leonguyenz · 1/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào tất cả mọi người,

2 đoạn code #3 và #6 đều chưa đúng ý tác giả thì phải. Nếu dữ liệu thêm 2 dòng 15,16 trong khung thì kết quả phải giống như bảng kết quả mong muốn ạ.
Oanh Thơ cũng chưa biết cách xử lý nên up lên để mong được mở mang thêm ạ.

View attachment 216322

Thì phải tùy biến thôi, không biết người dùng có thêm mắm thêm muối thế nào để mà lọc ra cái gọi là không trùng. Ví dụ cứ ghép đại 2 giá trị bằng 1 ký tự nối là @, biết đâu người dùng cũng đưa ký tự này vào?

Hoàng Nhật Phương · 1/5/19

leonguyenz đã viết:
Thì phải tùy biến thôi, không biết người dùng có thêm mắm thêm muối thế nào để mà lọc ra cái gọi là không trùng. Ví dụ cứ ghép đại 2 giá trị bằng 1 ký tự nối là @, biết đâu người dùng cũng đưa ký tự này vào?

Anh thử ghép "leonguyenz" chen vô giữa 2 giá trị chắc là không bao giờ lo trùng gì đâu ạ =))

SA_DQ · 2/5/19

Các bạn chưa thử sức với GPE.COM 1035 phân khối ư, đây & xin mời:
Bước chuẩn bị:
1 Tạo Validation nhóm các măt hàng (& dịch vụ) tại [G4]
2. Cũng tạo Validation các hàng hóa tại ô phải liền kề

Bước vi vu:
Tại [I4] ta áp công thức: =DSUM(B3: d65500,D3,G3:H4)

Hai Lúa Miền Tây · 2/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
Xin chào tất cả mọi người,

2 đoạn code #3 và #6 đều chưa đúng ý tác giả thì phải. Nếu dữ liệu thêm 2 dòng 15,16 trong khung thì kết quả phải giống như bảng kết quả mong muốn ạ.
Oanh Thơ cũng chưa biết cách xử lý nên up lên để mong được mở mang thêm ạ.

View attachment 216322

Dùng ADO nhé bạn.

Mã:

Sub CongDon_HLMT()
    With CreateObject("ADODB.Connection")
        .Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No""")
        Sheet1.Range("G4").CopyFromRecordset .Execute("Select F1,F2,Sum(F3),Sum(F4) from [Sheet1$B4:E] Where F4 Is Not Null Group By F1,F2")
    End With
End Sub

Hoàng Nhật Phương · 2/5/19

Hai Lúa Miền Tây đã viết:

Dùng ADO nhé bạn.

Mã:

Sub CongDon_HLMT()
    With CreateObject("ADODB.Connection")
        .Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No""")
        Sheet1.Range("G4").CopyFromRecordset .Execute("Select F1,F2,Sum(F3),Sum(F4) from [Sheet1$B4:E] Where F4 Is Not Null Group By F1,F2")
    End With
End Sub

Cảm ơn Anh Hai Lúa nhiều ạ,
OT đang tìm hiểu về mảng + dic , OT thấy chủ đề này cũng thấy khá hay và ứng dụng được nhiều vào thực tế (kiểu dạng sumifs).
ADO lợi hại thật đó , nhờ sự giúp đỡ của thành viên GPE mà OT cũng đã được sử dụng nhiều nhưng chưa bao giờ có ý định tìm hiểu vì mọi người bảo nó rất khó.

Cảm ơn Anh Hai Lúa đã chỉ thêm một cách để tham khảo ạ.

Hoàng Nhật Phương · 2/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
Cảm ơn Anh Hai Lúa nhiều ạ,
OT đang tìm hiểu về mảng + dic , OT thấy chủ đề này cũng thấy khá hay và ứng dụng được nhiều vào thực tế (kiểu dạng sumifs).
ADO lợi hại thật đó , nhờ sự giúp đỡ của thành viên GPE mà OT cũng đã được sử dụng nhiều nhưng chưa bao giờ có ý định tìm hiểu vì mọi người bảo nó rất khó.
Cảm ơn Anh Hai Lúa đã chỉ thêm một cách để tham khảo ạ.

Xin chào mọi người,
Vẫn là một cách phổ biến sử dụng Dic+Mảng, OT xin bon chen một cách mà OTđã từng nhận được giúp đỡ (code không phải của OT) ạ. OT đã sửa lại một chút để phù hợp với ví dụ trong đề tài, nếu có gì sai sót chưa hợp lý rất mong người góp ý.

Mã:

Sub gop_dong_cong_don()

'    khai bao bien
    Dim lastRow As Long, r As Long, c As Long, pos As Long
    Dim Arr(), item(), key As String, dic As Object
    
'    lam viec tren sheet1 cua chinh Workbook chua code
    With ThisWorkbook.Worksheets("Sheet1")
        lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
'        neu khong co du lieu thi ket thuc
        If lastRow < 4 Then Exit Sub
        
'        dung mang Arr vua cho du lieu nguon vua cho ket qua.
        Arr = .Range("B3:E" & lastRow).Value
        
'        Khoi tao Dic
        Set dic = CreateObject("Scripting.Dictionary")
'        Khong phan biet chu hoa chu thuong
        dic.CompareMode = vbTextCompare
'       phan biet chu hoa chu thuong
'        dic.CompareMode = vbBinaryCompare
        pos = 1
        'duyet tu dong 2 trong mang vi dong 1 la tieu de
        For r = 2 To UBound(Arr)
            'cot B, C tren sheet la cot 1,2 trong mang Arr ,noi 2 o tuong ung voi cot B,C bang ky tu Chr(0)
            key = Arr(r, 1) & Chr(0) & Arr(r, 2)
            If Not dic.exists(key) Then
'                dong dang xet chua co, vay ghi no tai dong pos trong mang Arr, dong thoi them 1 muc vao tu dien
'                voi key hien hanh va pos la item. Lam the thi ve sau khi gap key trung thi doc ra pos de biet dong
'                hien hanh se duoc gop voi dong nao da ghi truoc do
                pos = pos + 1
                For c = 1 To 4 ' tu B toi E co 4 cot
'                    ghi dong hien hanh voi tu cach ket qua vao dong pos
                    Arr(pos, c) = Arr(r, c)
                Next c
'                them key vao tu dien
                dic.Add key, pos
            Else
'                dong hien hanh trung voi 1 dong nao do da ghi truoc do
'                doc ra chi so dong ma dong co cung key da duoc ghi trong mang Arr
                pos = dic.item(key)
'                Ta gop dong hien hanh voi dong co chi so pos
                For c = 3 To 4 ' gop 2 cot tu cot D (cot 3) toi cot E (cot 4)
'                    chi gop o cot khi 1 trong 2 gia tri khong rong
                    If Not IsEmpty(Arr(pos, c)) Or Not IsEmpty(Arr(r, c)) Then
                        Arr(pos, c) = Arr(pos, c) + Arr(r, c)
                    End If
                Next c
            End If
        Next r
'    nhap ket qua xuong sheet. Do ket qua chi nam o pos dong dau nen tuy ta dap ca mang xuong sheet nhung
'    neu ta gioi han vung nhan ket qua tren sheet thi ket qua chi hien thi o gioi han do.
'    O day ta gioi han vung nhan ket qua chi co pos dong nen chi co pos dong dau cua mang Arr duoc nhap xuong sheet.
        .Range("G3").Resize(pos, UBound(Arr, 2)).Value = Arr
    End With
    Set dic = Nothing
End Sub

---
Híc, cứ thấy anh chủ thớt là em lại ước mazda T_T

VetMini · 2/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
...Híc, cứ thấy anh chủ thớt là em lại ước mazda T_T

Ước chi. Cứ cố gắng làm được như thớt thì sẽ có thôi.
1. Đầu tiên hết, bạn phải "rất giỏi", có khả năng tự giải tất cả các vấn đề, từ lớn đến nhỏ, từ phần mềm đến phần cứng, phần xốp/dẻo (software, hardware, firmware).
2. Kế đó bạn phải có "kiên trì", tự giải được nhưng vẫn lên diễn đàn năn nỉ ỷ ôi tìm các cách giải khác.
3. Cuối cùng bạn phải có lòng "bảo mật", tuy hỏi người khác chia sẻ cách giải nhưng không bao giờ chia sẻ cách của mình. (*)

(*) Lâu lâu chụp một đoạn code đưa lên không phải là để chia sẻ - code C++ gọi class mà không có code class, hay ít nhất phần đã compile của class thì chỉ là đồ mã, dùng để khoe. Lấy cớ là "không ai có khả năng hiểu nổi"

Hoàng Nhật Phương · 2/5/19

VetMini đã viết:
Ước chi. Cứ cố gắng làm được như thớt thì sẽ có thôi.
1. Đầu tiên hết, bạn phải "rất giỏi", có khả năng tự giải tất cả các vấn đề, từ lớn đến nhỏ, từ phần mềm đến phần cứng, phần xốp/dẻo (software, hardware, firmware).
2. Kế đó bạn phải có "kiên trì", tự giải được nhưng vẫn lên diễn đàn năn nỉ ỷ ôi tìm các cách giải khác.
3. Cuối cùng bạn phải có lòng "bảo mật", tuy hỏi người khác chia sẻ cách giải nhưng không bao giờ chia sẻ cách của mình. (*)

(*) Lâu lâu chụp một đoạn code đưa lên không phải là để chia sẻ - code C++ gọi class mà không có code class, hay ít nhất phần đã compile của class thì chỉ là đồ mã, dùng để khoe. Lấy cớ là "không ai có khả năng hiểu nổi"

Hi,Bác VetMini có vẻ rất quan tâm đến Anh chủ thớt

Anh ấy thật may mắn.

VetMini · 2/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
Hi,Bác VetMini có vẻ rất quan tâm đến Anh chủ thớt
Anh ấy thật may mắn.

Ai có tiền có của tôi đều quan tâm hết. Mà những người này đâu có cần "may mắn", cho nên họ cũng chả quan tâm đến quan tâm của tôi.

(Tôi mặc định từ "hi" có nghĩa là tiếng cười. Nếu nó là điệu "háy" kiểu tây u thì kể từ rày, tôi chấm dứt quan tâm)

Hoàng Nhật Phương · 2/5/19

VetMini đã viết:
Ai có tiền có của tôi đều quan tâm hết. Mà những người này đâu có cần "may mắn", cho nên họ cũng chả quan tâm đến quan tâm của tôi.

(Tôi mặc định từ "hi" có nghĩa là tiếng cười. Nếu nó là điệu "háy" kiểu tây u thì kể từ rày, tôi chấm dứt quan tâm)

Dạ Bác, vâng con viết tiếng Việt. Bác hiểu có nghĩa là tiếng cười là đúng rồi.
Con cảm ơn Bác đã quan tâm ạ.

Giúp code cộng dồn SL và Thành tiền khi trùng 2 cột

Thành viên bị đình chỉ hoạt động

File đính kèm

Thành viên tích cực

File đính kèm

Thành viên gạo cội

File đính kèm

Thành viên bị đình chỉ hoạt động

Thành viên bị đình chỉ hoạt động

Thành viên tích cực

Ăn cùng góc phố

Thành viên gắn bó

Thành viên gạo cội

Thành viên gắn bó

/(hông là gì!

❆❆❆❆❆❆❆❆

Thành viên gắn bó

Thành viên gắn bó

Ăn cùng góc phố

Thành viên gắn bó

Ăn cùng góc phố

Thành viên gắn bó

Facebook

Group