Xoa hàng giống nhau nhưng giữ hàng trên cùng và cộng dồn

hadoan-pap · 22/11/18

Dear các Anh/Chị

Em có 1 bài toán nhỏ mong mọi ng giúp đỡ như trong file đính kèm ạ.

- Sẽ xóa các Row có " Mã " going nhau, nhưng giữ lại cái trên cùng
- Trước khi xóa Row thì cộng các giá trị của cột FC và ACT lại... Vi dụ trong bài toán là với mã " SD1" thì cộng FC+ACT lại rồi mới bắt đầu xóa dòng bên dưới. Khi ấn nút k phải nó tham chiếu xuống như hình mà e trình bày mà nó xóa dòng và đè vào vị trí cũ luôn ạ.

file thực tê thì rất nh Item Mã going nhau trải dài từ trên xuống, nên e muốn làm như vậy để collect lại ạ.

E xin cảm ơn!

thanchetvnt · 22/11/18

hadoan-pap đã viết:
Dear các Anh/Chị

Em có 1 bài toán nhỏ mong mọi ng giúp đỡ như trong file đính kèm ạ.

- Sẽ xóa các Row có " Mã " going nhau, nhưng giữ lại cái trên cùng
- Trước khi xóa Row thì cộng các giá trị của cột FC và ACT lại... Vi dụ trong bài toán là với mã " SD1" thì cộng FC+ACT lại rồi mới bắt đầu xóa dòng bên dưới. Khi ấn nút k phải nó tham chiếu xuống như hình mà e trình bày mà nó xóa dòng và đè vào vị trí cũ luôn ạ.

file thực tê thì rất nh Item Mã going nhau trải dài từ trên xuống, nên e muốn làm như vậy để collect lại ạ.

E xin cảm ơn!

Của bạn đây. Bấm vào Button 1 rồi xem kết quả bên dưới hoặc bên Sheet 2 nhé.

hadoan-pap · 23/11/18

thanchetvnt đã viết:
Của bạn đây. Bấm vào Button 1 rồi xem kết quả bên dưới hoặc bên Sheet 2 nhé.

Dear bạn,

Cảm ơn bạn nh nhé. Nhưng mình đang loay hoay đoạn code dưới vì quen dung dạng này mà k biết sai ở đâu k chạy đc. Bạn check giúp minh với nhé. Riêng phần delete Row thì mình hiểu rồi, chỉ đang khúc mắc phần check và cộng giá trị.

Dim arr, arr1
Dim i, a As Long, j As Long

arr = Sheet1.Range("B1:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value
arr1 = Sheet1.Range("B1:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value
ReDim arr2(1 To UBound(arr1, 1), 1 To 1)

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr, 1)
If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
arr2(i, 4) = arr(j, 2) + arr1(i, 3)
End If
Next j
Next i

snow25 · 23/11/18

hadoan-pap đã viết:
Dear các Anh/Chị

Em có 1 bài toán nhỏ mong mọi ng giúp đỡ như trong file đính kèm ạ.

- Sẽ xóa các Row có " Mã " going nhau, nhưng giữ lại cái trên cùng
- Trước khi xóa Row thì cộng các giá trị của cột FC và ACT lại... Vi dụ trong bài toán là với mã " SD1" thì cộng FC+ACT lại rồi mới bắt đầu xóa dòng bên dưới. Khi ấn nút k phải nó tham chiếu xuống như hình mà e trình bày mà nó xóa dòng và đè vào vị trí cũ luôn ạ.

file thực tê thì rất nh Item Mã going nhau trải dài từ trên xuống, nên e muốn làm như vậy để collect lại ạ.

E xin cảm ơn!

đây bạn xem code

Mã:

Sub tinhtong()
Dim a As Double, b As Double, i As Long, j As Long, k As Long, m As Long
Dim arr, arr1
Dim dk As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("b2:e8").Value
    ReDim arr1(1 To UBound(arr, 1), 1 To 4)
          For i = 1 To UBound(arr, 1)
             dk = arr(i, 1)
              If dic.exists(dk) = 0 Then
                 k = k + 1
                    If arr(i, 2) = Empty Then arr(i, 2) = 0
                    If arr(i, 3) = Empty Then arr(i, 3) = 0
                    dic.Item(dk) = Array(arr(i, 2), arr(i, 3), k)
                    arr1(k, 1) = dk
                    arr1(k, 2) = arr(i, 2)
                 Else
                    a = dic.Item(dk)(0)
                    b = dic.Item(dk)(1)
                    a = a + arr(i, 2)
                    b = b + arr(i, 3)
                    m = dic.Item(dk)(2)
                    arr1(m, 4) = a + b
                    dic.Item(dk) = Array(a, b, m)
                 End If
        Next i
   .Range("b12:e15").ClearContents
  .Range("b12").Resize(k, 4).Value = arr1
End With
End Sub

hadoan-pap · 23/11/18

snow25 đã viết:

đây bạn xem code

Mã:

Sub tinhtong()
Dim a As Double, b As Double, i As Long, j As Long, k As Long, m As Long
Dim arr, arr1
Dim dk As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("b2:e8").Value
    ReDim arr1(1 To UBound(arr, 1), 1 To 4)
          For i = 1 To UBound(arr, 1)
             dk = arr(i, 1)
              If dic.exists(dk) = 0 Then
                 k = k + 1
                    If arr(i, 2) = Empty Then arr(i, 2) = 0
                    If arr(i, 3) = Empty Then arr(i, 3) = 0
                    dic.Item(dk) = Array(arr(i, 2), arr(i, 3), k)
                    arr1(k, 1) = dk
                    arr1(k, 2) = arr(i, 2)
                 Else
                    a = dic.Item(dk)(0)
                    b = dic.Item(dk)(1)
                    a = a + arr(i, 2)
                    b = b + arr(i, 3)
                    m = dic.Item(dk)(2)
                    arr1(m, 4) = a + b
                    dic.Item(dk) = Array(a, b, m)
                 End If
        Next i
   .Range("b12:e15").ClearContents
  .Range("b12").Resize(k, 4).Value = arr1
End With
End Sub

Dear Snow,

Cảm ơn cậu nhé. Code hơi dài nên đọc mình thấy hơi khó hiểu.

Mình có làm đoạn code này nó chạy đúng như mình mong muốn, nhưng nó chạy rất chậm nếu tang giá trị hang lên vài tram hoặc nghìn.

Mình k cần code delete hang đâu, mình chỉ cần nó chạy tham chiếu giá trị going nhau thì cộng lại kết quả như trong file đính kèm.

Cậu giúp mình tham chiếu theo Array dựa vào code bên dươi đc k?

Dim i, j As Integer

For i = 2 To 100
For j = 2 To 100

If Sheet1.Cells(i, 2) = Sheet1.Cells(j, 2) Then

Sheet1.Cells(i, 5) = Sheet1.Cells(i, 3) + Sheet1.Cells(j, 4)

End If

Next j
Next i

thanh.bq · 23/11/18

hadoan-pap đã viết:
Dear Snow,

Cảm ơn cậu nhé. Code hơi dài nên đọc mình thấy hơi khó hiểu.

Mình có làm đoạn code này nó chạy đúng như mình mong muốn, nhưng nó chạy rất chậm nếu tang giá trị hang lên vài tram hoặc nghìn.

Mình k cần code delete hang đâu, mình chỉ cần nó chạy tham chiếu giá trị going nhau thì cộng lại kết quả như trong file đính kèm.

Cậu giúp mình tham chiếu theo Array dựa vào code bên dươi đc k?

Dim i, j As Integer

For i = 2 To 100
For j = 2 To 100

If Sheet1.Cells(i, 2) = Sheet1.Cells(j, 2) Then

Sheet1.Cells(i, 5) = Sheet1.Cells(i, 3) + Sheet1.Cells(j, 4)

End If

Next j
Next i

Bạn thử Code này xem sao.

Mã:

Sub Button1_Click()
Dim i, j As long
Dim Arr

i = Range("B" & Rows.Count).End(xlUp).Row
Arr = Range("B2:D" & i).Value
Redim preserve arr(1 to ubound(arr,1),1 to 4)
For i = 1 To UBound(Arr, 1)
    For j = 1 To UBound(Arr, 1)
        If Arr(i, 1) = Arr(j, 1) Then
            Arr(i, 4) = Arr(i, 4)+Arr(i, 2) + Arr(j, 3)
        End If
    Next j
Next I
Range("B2").Resize(UBound(Arr, 1), 4).Value = Arr
End Sub

snow25 · 23/11/18

thanh.bq đã viết:

Bạn thử Code này xem sao.

Mã:

Sub Button1_Click()
Dim i, j As long
Dim Arr

i = Range("B" & Rows.Count).End(xlUp).Row
Arr = Range("B2:D" & i).Value
Redim preserve arr(1 to ubound(arr,1),1 to 4)
For i = 1 To UBound(Arr, 1)
    For j = 1 To UBound(Arr, 1)
        If Arr(i, 1) = Arr(j, 1) Then
            Arr(i, 4) = Arr(i, 4)+Arr(i, 2) + Arr(j, 3)
        End If
    Next j
Next I
Range("B2").Resize(UBound(Arr, 1), 4).Value = Arr
End Sub

Code này nó vẫn lồng vòng lặp.Nên mình nghĩ nó vẫn bị chậm nhé bạn.

hadoan-pap · 23/11/18

thanh.bq đã viết:

Bạn thử Code này xem sao.

Mã:

Sub Button1_Click()
Dim i, j As long
Dim Arr

i = Range("B" & Rows.Count).End(xlUp).Row
Arr = Range("B2:D" & i).Value
Redim preserve arr(1 to ubound(arr,1),1 to 4)
For i = 1 To UBound(Arr, 1)
    For j = 1 To UBound(Arr, 1)
        If Arr(i, 1) = Arr(j, 1) Then
            Arr(i, 4) = Arr(i, 4)+Arr(i, 2) + Arr(j, 3)
        End If
    Next j
Next I
Range("B2").Resize(UBound(Arr, 1), 4).Value = Arr
End Sub

Dear bạn,

Cảm ơn bạn rất nhiều... Code này mình thấy ổn bạn ạ và mình dễ hiểu hơn.

Mình k hiểu lắm dòng này " Redim preserve arr(1 to ubound(arr,1),1 to 4) " Ý nghĩa là gì vậy bạn?

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

snow25 đã viết:
Code này nó vẫn lồng vòng lặp.Nên mình nghĩ nó vẫn bị chậm nhé bạn.

Cảm ơn Snow nhé... Code đó mình thử chạy thấy kết quả cũng đúng và cũng khá nhanh cậu ah..

Cảm ơn mọi ng nh lắm.

snow25 · 23/11/18

hadoan-pap đã viết:
Dear bạn,

Cảm ơn bạn rất nhiều... Code này mình thấy ổn bạn ạ và mình dễ hiểu hơn.

Mình k hiểu lắm dòng này " Redim preserve arr(1 to ubound(arr,1),1 to 4) " Ý nghĩa là gì vậy bạn?

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

Cảm ơn Snow nhé... Code đó mình thử chạy thấy kết quả cũng đúng và cũng khá nhanh cậu ah..

Cảm ơn mọi ng nh lắm.

Cái Redim preserve arr(1 to ubound(arr,1),1 to 4) dùng để khai báo mảng.Khi cần mở rộng thêm mảng mà không làm mất giá trị ban đầu của mảng đó.Còn code này nó chậm khi dữ liệu lớn tầm 10 nghìn dòng nhé bạn.

hadoan-pap · 23/11/18

snow25 đã viết:
Cái Redim preserve arr(1 to ubound(arr,1),1 to 4) dùng để khai báo mảng.Khi cần mở rộng thêm mảng mà không làm mất giá trị ban đầu của mảng đó.Còn code này nó chậm khi dữ liệu lớn tầm 10 nghìn dòng nhé bạn.

Dear Snow,

Cảm ơn cậu nhé ... Data cua tớ chắc tầm 2-3 nghìn đổ lại ^^

Ah, cậu cho tớ xin đoạn Code khi tớ muốn tìm từ dòng B20 đến B50, dòng nào trống thì tớ paste data nhé.

Tớ search google thì toàn thấy là nó tìm cả cột B, tớ chỉ muôn

thanh.bq · 27/11/18

snow25 đã viết:
Code này nó vẫn lồng vòng lặp.Nên mình nghĩ nó vẫn bị chậm nhé bạn.

mình viết lại theo yêu cầu của bạn hadoan-pap thui. nếu muốn nhanh hơn thì chắc dùng Dic thì được.

Xoa hàng giống nhau nhưng giữ hàng trên cùng và cộng dồn

hadoan-pap

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

File đính kèm

thanchetvnt

Thành viên chính thức

File đính kèm

hadoan-pap

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

snow25

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

hadoan-pap

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

File đính kèm

thanh.bq

Thành viên chính thức

snow25

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

hadoan-pap

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

snow25

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

hadoan-pap

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

thanh.bq

Thành viên chính thức

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng