Tìm cell giống nhau cộng lại và delete shift xlup

[hadoan-pap]

Kính gửi mọi ng.

em có 1 bài toán như file đính kèm ạ. Mình tìm cột D xem mã nào going nhau thì sẽ cộng lại giá trị vào ô phía trên ở cột E, sau đó sẽ xóa những item going nhau bên dưới. Khi delete dòng thì chỉ delete Shift xlup trong range ("C:E"), k xóa toàn bộ hang ạ.

Mọi ng giúp em với nhé.

E cảm ơn ạ!

 

[snow25]

Kính gửi mọi ng.

em có 1 bài toán như file đính kèm ạ. Mình tìm cột D xem mã nào going nhau thì sẽ cộng lại giá trị vào ô phía trên ở cột E, sau đó sẽ xóa những item going nhau bên dưới. Khi delete dòng thì chỉ delete Shift xlup trong range ("C:E"), k xóa toàn bộ hang ạ.

Mọi ng giúp em với nhé.

E cảm ơn ạ!

Sub gop()
Dim a As Long, b As Long, i As Long
Dim arr, arr1
Dim dk As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet6
     b = .Range("D" & rows.Count).End(xlUp).Row
     If b > 7 Then arr = .Range("c8:e" & b).Value Else MsgBox "khong co du lieu": Exit Sub
     ReDim arr1(1 To UBound(arr, 1), 1 To 3)
           For i = 1 To UBound(arr, 1)
               dk = arr(i, 2)
               If dic.exists(dk) = 0 Then
                  a = a + 1
                  dic.Item(dk) = Array(a)
                  arr1(a, 1) = a
                  arr1(a, 2) = arr(i, 2)
                  arr1(a, 3) = arr(i, 3)
               Else
                  arr1(dic.Item(dk)(0), 3) = arr1(dic.Item(dk)(0), 3) + arr(i, 3)
               End If
          Next i
     .Range("C8:E" & b).ClearContents
     If a Then .Range("c8").Resize(a, 3).Value = arr1
End With
End Sub

Đây bạn xem.

 

[thuyyeu99]

Kính gửi mọi ng.

em có 1 bài toán như file đính kèm ạ. Mình tìm cột D xem mã nào going nhau thì sẽ cộng lại giá trị vào ô phía trên ở cột E, sau đó sẽ xóa những item going nhau bên dưới. Khi delete dòng thì chỉ delete Shift xlup trong range ("C:E"), k xóa toàn bộ hang ạ.

Mọi ng giúp em với nhé.

E cảm ơn ạ!

Chiều giờ bận việc chuyên môn quá đúng theo yêu cầu của bạn đây

Sub DeleteRangeShiftxlUp()
    Dim i As Long, r As Long
    Dim Rng As Range, Cls As Range, dRg As Range, TmpArr As Variant
   
    Set dict = CreateObject("scripting.dictionary")
    ReDim TmpArr(1 To ActiveSheet.Range("D65500").End(xlUp).Row)
    Set Rng = Range("C8:E" & ActiveSheet.Range("C65500").End(xlUp).Row)
    For Each Cls In Rng.Columns(2).Cells
        If Cls.Value <> "" Then
            If Not dict.exists(Cls.Value) Then
                a = Cls.Row
                dict.Add Cls.Value, a
                'TmpArr(a) = Cls.Offset(, 1).Value
            Else
                x = dict.Item(Cls.Value)
                'Cells(x, Cls.Offset(, 1).Column).Value = TmpArr(x) + Cls.Offset(, 1).Value
                Cells(x, Cls.Offset(, 1).Column).Value = Cells(x, Cls.Offset(, 1).Column).Value + Cls.Offset(, 1).Value
                If Not dRg Is Nothing Then
                    Set dRg = Union(dRg, Rng.Rows(Cls.Row - Rng.Row + 1))    '
                Else
                    Set dRg = Rng.Rows(Cls.Row - Rng.Row + 1)
                End If
            End If
        End If
    Next Cls
    If Not dRg Is Nothing Then
        dRg.Delete Shift:=xlUp
    End If
End Sub

 

[vanthinh3101]

Kính gửi mọi ng.

em có 1 bài toán như file đính kèm ạ. Mình tìm cột D xem mã nào going nhau thì sẽ cộng lại giá trị vào ô phía trên ở cột E, sau đó sẽ xóa những item going nhau bên dưới. Khi delete dòng thì chỉ delete Shift xlup trong range ("C:E"), k xóa toàn bộ hang ạ.

Mọi ng giúp em với nhé.

E cảm ơn ạ!

Tôi có ý tưởng hơi ngược 1 chút.
Nếu dữ liệu lớn, tôi nghĩ Delete sẽ làm tốc độ code bị chậm.
Vì vậy, tôi sẽ lấy kết quả ra 1 mảng, xóa toàn bộ dữ liệu cũ rồi dán mảng kết quả.

Sub DeleteCells()
    Dim sArr(), dArr(), Dic As Object
    Dim I As Long, J As Long, K As Long
    
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr() = Range("C8", Range("C8").End(xlDown)).Resize(, 3).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    
    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 2)) Then
            K = K + 1: Dic.Add sArr(I, 2), K
            For J = 1 To 4
                dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
                dArr(K, 3) = sArr(I, 3)
            Next J
        Else
            dArr(Dic.Item(sArr(I, 2)), 3) = dArr(Dic.Item(sArr(I, 2)), 3) + sArr(I, 3)
        End If
    Next I
    Range("C8", Range("C8").End(xlDown)).Resize(, 3).ClearContents
    Range("C8").Resize(K, UBound(dArr, 2)) = dArr
    
    Set Dic = Nothing
    MsgBox "Done", vbInformation, "GPE"
End Sub

 

[Ba Tê]

For J = 1 To 4
                dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
                dArr(K, 3) = sArr(I, 3)
Next J

For J này để làm gì vậy?

 

[thuyyeu99]

Arr thì chắc chắn phải nhanh hơn Range rồi
Add Arr= Range nguyên vùng rồi tìm lọc trên Arr , Clear rồi gán vào la lẹ nhất, nhưng chủ Top muốn Delete Shift:=xlUp, mình cũng không biết mần chi

 

[vanthinh3101]

For J = 1 To 4
                dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
                dArr(K, 3) = sArr(I, 3)
Next J

For J này để làm gì vậy?

Ôi ngại quá thầy ạ.
Em định dùng vòng lặp để duyệt qua các cột, sau dữ liệu ít nên không dùng nữa.
Vậy mà quên mất không bỏ đi.

 

[hadoan-pap]

Sub gop()
Dim a As Long, b As Long, i As Long
Dim arr, arr1
Dim dk As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet6
     b = .Range("D" & rows.Count).End(xlUp).Row
     If b > 7 Then arr = .Range("c8:e" & b).Value Else MsgBox "khong co du lieu": Exit Sub
     ReDim arr1(1 To UBound(arr, 1), 1 To 3)
           For i = 1 To UBound(arr, 1)
               dk = arr(i, 2)
               If dic.exists(dk) = 0 Then
                  a = a + 1
                  dic.Item(dk) = Array(a)
                  arr1(a, 1) = a
                  arr1(a, 2) = arr(i, 2)
                  arr1(a, 3) = arr(i, 3)
               Else
                  arr1(dic.Item(dk)(0), 3) = arr1(dic.Item(dk)(0), 3) + arr(i, 3)
               End If
          Next i
     .Range("C8:E" & b).ClearContents
     If a Then .Range("c8").Resize(a, 3).Value = arr1
End With
End Sub

Đây bạn xem.

Snow ơi nếu muốn xóa trong Range A5:E thì phải sửa đoạn nào và them code tnao cậu nhỉ ?

Trong code là xóa từ C5:E

 

[snow25]

Snow ơi nếu muốn xóa trong Range A5:E thì phải sửa đoạn nào và them code tnao cậu nhỉ ?

Trong code là xóa từ C5:E

Bạn gửi file mẫu lên chứ.Nói thế này khó lắm vì không biết dữ liệu thế nào.

 

[hadoan-pap]

Chiều giờ bận việc chuyên môn quá đúng theo yêu cầu của bạn đây

Sub DeleteRangeShiftxlUp()
    Dim i As Long, r As Long
    Dim Rng As Range, Cls As Range, dRg As Range, TmpArr As Variant
  
    Set dict = CreateObject("scripting.dictionary")
    ReDim TmpArr(1 To ActiveSheet.Range("D65500").End(xlUp).Row)
    Set Rng = Range("C8:E" & ActiveSheet.Range("C65500").End(xlUp).Row)
    For Each Cls In Rng.Columns(2).Cells
        If Cls.Value <> "" Then
            If Not dict.exists(Cls.Value) Then
                a = Cls.Row
                dict.Add Cls.Value, a
                'TmpArr(a) = Cls.Offset(, 1).Value
            Else
                x = dict.Item(Cls.Value)
                'Cells(x, Cls.Offset(, 1).Column).Value = TmpArr(x) + Cls.Offset(, 1).Value
                Cells(x, Cls.Offset(, 1).Column).Value = Cells(x, Cls.Offset(, 1).Column).Value + Cls.Offset(, 1).Value
                If Not dRg Is Nothing Then
                    Set dRg = Union(dRg, Rng.Rows(Cls.Row - Rng.Row + 1))    '
                Else
                    Set dRg = Rng.Rows(Cls.Row - Rng.Row + 1)
                End If
            End If
        End If
    Next Cls
    If Not dRg Is Nothing Then
        dRg.Delete Shift:=xlUp
    End If
End Sub

Cảm ơn bạn nh nhé. Mình đã dung code của bạn , edit vào bài của mình đc rồi

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

Bạn gửi file mẫu lên chứ.Nói thế này khó lắm vì không biết dữ liệu thế nào.

Cảm ơn cậu nhé.

Cách của mọi ng đều đúng ... Tớ đã thử và ok rồi