Nhờ các anh chị giúp code lọc gọn dữ liệu (3 người xem)

[Văn Toàn 1996]

Chào các anh chị Diễn đàn. Em cần rút gọn dữ liệu như hình mô tả bên dưới . Vùng Data: B4:E1000
- Nếu giá trị của dòng cột B ="" thì không chạy code dòng đó
- Nếu giá trị của dòng cột D >0 hoặc giá trị của dòng cột E không phải là số thì không cần lọc xuất ra vẫn giữ nguyên như cũ
- Nếu giá trị của dòng cột D ="" thì lọc cộng dồn cột giá phụ và xuất ra kèm ô ghi chú như hình bên dưới
Em xin cảm ơn

 

[bebo021999]

Xài đỡ code này trong khi chờ code khác hay hơn:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, rng, key
Dim res(1 To 10000, 1 To 5), dic As Object, id As String
lr = Cells(Rows.Count, "C").End(xlUp).Row
rng = Range("B4:E" & lr).Value
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(rng)
    If rng(i, 3) > 0 Or Not IsNumeric(rng(i, 4)) Then
        k = k + 1
        For j = 1 To 4
            res(k, j) = rng(i, j)
        Next
    Else
        id = rng(i, 2) & "|" & rng(i, 4)
        If Not dic.exists(id) Then
            k = k + 1
            For j = 1 To 4
                res(k, j) = rng(i, j)
            Next
            dic.Add id, 1
        Else
            dic(id) = dic(id) + 1
        End If
    End If
Next
If k = 0 Then Exit Sub
For Each key In dic.keys
    If dic(key) > 1 Then
        For i = 1 To k
            If key = res(i, 2) & "|" & res(i, 4) Then
                res(i, 5) = res(i, 4) & " x " & dic(key)
                res(i, 4) = res(i, 4) * dic(key)
                Exit For
            End If
        Next
    End If
Next
Range("H4:L10000").ClearContents
Range("H4").Resize(k, 5).Value = res
End Sub

 

[ngocbaovu]

Thử đoạn code này xem

Sub Loc()
    Dim i, j, k, l, lr As Long
    
    lr = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 2 To lr
        If Cells(i, "D").Value > 0 Or Not IsNumeric(Cells(i, "E").Value) Then
           GoTo Nexti
        End If
        k = Cells(i, "E").Value
        l = 1
        For j = i + 1 To lr
            If Cells(i, "C").Value = Cells(j, "C").Value And Cells(j, "E").Value = k Then
                Cells(i, "E").Value = Cells(i, "E").Value + Cells(j, "E").Value
                Rows(j).Delete
                lr = lr - 1
                j = j - 1
                l = l + 1
            End If
        Next j
        If l > 1 Then
        Cells(i, "F").Value = k & "x" & l
        End If
Nexti:
   Next i
End Sub

 

[Văn Toàn 1996]

Xài đỡ code này trong khi chờ code khác hay hơn:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, rng, key
Dim res(1 To 10000, 1 To 5), dic As Object, id As String
lr = Cells(Rows.Count, "C").End(xlUp).Row
rng = Range("B4:E" & lr).Value
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(rng)
    If rng(i, 3) > 0 Or Not IsNumeric(rng(i, 4)) Then
        k = k + 1
        For j = 1 To 4
            res(k, j) = rng(i, j)
        Next
    Else
        id = rng(i, 2) & "|" & rng(i, 4)
        If Not dic.exists(id) Then
            k = k + 1
            For j = 1 To 4
                res(k, j) = rng(i, j)
            Next
            dic.Add id, 1
        Else
            dic(id) = dic(id) + 1
        End If
    End If
Next
If k = 0 Then Exit Sub
For Each key In dic.keys
    If dic(key) > 1 Then
        For i = 1 To k
            If key = res(i, 2) & "|" & res(i, 4) Then
                res(i, 5) = res(i, 4) & " x " & dic(key)
                res(i, 4) = res(i, 4) * dic(key)
                Exit For
            End If
        Next
    End If
Next
Range("H4:L10000").ClearContents
Range("H4").Resize(k, 5).Value = res
End Sub

dạ cảm ơn anh ạ. Code đúng ý em luôn. Anh có thêm cho em phần ghi chú Min,Max . Nếu cột giá Phụ (cột E ) <=50 thì "Min" ngược lại là "max"
Em chân thành cảm ơn anh ạ .

Bài đã được tự động gộp: 5/6/23

Thử đoạn code này xem

Sub Loc()
    Dim i, j, k, l, lr As Long
   
    lr = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 2 To lr
        If Cells(i, "D").Value > 0 Or Not IsNumeric(Cells(i, "E").Value) Then
           GoTo Nexti
        End If
        k = Cells(i, "E").Value
        l = 1
        For j = i + 1 To lr
            If Cells(i, "C").Value = Cells(j, "C").Value And Cells(j, "E").Value = k Then
                Cells(i, "E").Value = Cells(i, "E").Value + Cells(j, "E").Value
                Rows(j).Delete
                lr = lr - 1
                j = j - 1
                l = l + 1
            End If
        Next j
        If l > 1 Then
        Cells(i, "F").Value = k & "x" & l
        End If
Nexti:
   Next i
End Sub

Em chân thành cảm ơn anh ạ. Giờ em đang dùng điện thoại để tối em ngồi máy em xem . cảm ơn anh nhiều ạ

 

[bebo021999]

dạ cảm ơn anh ạ. Code đúng ý em luôn. Anh có thêm cho em phần ghi chú Min,Max . Nếu cột giá Phụ (cột E ) <=50 thì "Min" ngược lại là "max"

Đơn giản mà, nếu bạn hiểu cách code nó vận hành thì bổ sung trong vòng 1 nốt nhạc thôi
Cũ

res(i, 5) = res(i, 4) & " x " & dic(key)

Mới

res(i, 5) = res(i, 4) & " x " & dic(key) & IIf(res(i, 4) <= 50, " Min", " Max")