cám ơn 2 bác đã giúp đỡ. dữ liệu gốc không phải do em làm mà em nhận từ người khác nên khi đó đã có merge cell rồi. dữ liệu gốc khoảng 10000 dòng và 16 cột. cái khó nữa là cột date và part no ở phần kết quả chưa có,mình phải tự tạo ra nên cần tạo nó trước để lấy cơ sở tính toán. mong các bác giúp đỡMình nghĩ, thay vì ngồi nghĩ cách tổng hợp dữ liệu từ mấy ô bị merge, ta bỏ merge đi rồi tính còn nhanh hơn...
Còn không thì làm kiểu củ chuối như file đính kèm này:
Sub SumMerge()
' Phien ban thu nghiem, chi tong hop 1 so lieu o cot cuoi cung
Const sTab = "sTable", sTgHop = "TongHop"
Dim sRa As Range, dRa As Range, sTH As Worksheet, sDT As Worksheet
Dim iR As Long, pR As Long, tR As Long, kR As Long
Dim sR As Long, sC As Long, sM As Long, sVal
Application.ScreenUpdating = False
Set sDT = ActiveSheet
On Error Resume Next
Set sRa = sDT.Range(sTab).CurrentRegion
' Neu chua dat ten cho vi tri dau tien cua bang so lieu la sTable thi lay vung chon hien thoi '
If sRa Is Nothing Then
Set sRa = ActiveCell.CurrentRegion
End If
Set sTH = Sheets(sTgHop)
' Neu chua co sheet TongHop thi chen them 1 sheet va dat ten la TongHop '
If sTH Is Nothing Then
With ThisWorkbook.Sheets.Add
Set sTH = ActiveSheet
sTH.Name = sTgHop
End With
End If
On Error GoTo 0
Set dRa = sTH.Cells(sRa.Row, sRa.Column)
sDT.Activate
' Tinh tong so dong cua bang so lieu '
sR = sRa.Rows.Count
' vi tri tong hop so lieu duoc gia su la cot cuoi cung cua bang so lieu '
' neu vi tri nay khong nam o cuoi thi gan lai gia tri cho bien sC '
' neu trong bang so lieu co nhieu cot can tong hop thi khai bao 1 bien array de xu ly '
sC = sRa.Columns.Count
iR = 1
kR = 1
Do
tR = iR
pR = kR
Do While iR <= sR And Not sRa(iR, 1).MergeCells
iR = iR + 1
kR = kR + 1
Loop
sRa.Offset(tR - 1, 0).Resize(iR - tR, sC).Copy Destination:=dRa(pR, 1)
If sRa(iR, 1).MergeCells Then
sM = sRa(iR, 1).MergeArea.Rows.Count
sRa.Offset(iR - 1, 0).Resize(1, sC).Copy Destination:=dRa(kR, 1)
' ======================================================= '
sVal = WorksheetFunction.Sum(sRa(iR, sC).Resize(sM, 1)) ' tinh toan so lieu
dRa(kR, sC) = sVal ' tong hop so lieu '
' ======================================================= '
kR = kR + 1
iR = iR + sRa(iR, 1).MergeArea.Rows.Count
End If
Loop Until iR > sR
sTH.Activate
Set sDT = Nothing: Set sRa = Nothing
Set sTH = Nothing: Set dRa = Nothing
Application.ScreenUpdating = True
End SubVậy thì bạn đâu cần phải tạo ra một vùng dữ liệu làm gì chỉ cần tạo cột phụ như tôi làm sau đó dùng auto filter lọc bỏ các cell rỗng là được kết quả như ý ,không cần dùng Sumproduct cho nặng file.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo LoiWCh
If Not Intersect(Target, [d3]) Is Nothing Then
Dim Rng As Range, sRng As Range
Dim Zz As Long, jRw As Long: Dim Sh As Worksheet
Application.ScreenUpdating = False: Set Sh = Sheets("Data")
Set Rng = Sh.Range(Sh.[i1], Sh.[i65500].End(xlUp))
Set sRng = Rng.Find(Format(Target.Value, "Short Date"), , xlFormulas)
If Not sRng Is Nothing Then
jRw = sRng.End(xlDown).Row - sRng.Row
Set Rng = [b65500].End(xlUp).Offset(1, -1)
Rng.Resize(jRw, 13).Value = sRng.Offset(, -8).Resize(jRw, 13).Value
If jRw > 1 Then
For Zz = 1 To 13
Rng.Offset(, Zz - 1).Resize(jRw).Select
With Selection
.VerticalAlignment = xlCenter
If Zz <> 2 And Zz <> 7 Then _
.MergeCells = True
End With
Next Zz
End If: End If
End If: [d4].Select
Exit Sub
LoiWCh: End SubOption Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo LoiWCh
Dim Rng As Range, sRng As Range, cRng As Range
Dim Zz As Long, jRw As Long: Dim Sh As Worksheet
Dim MyAdd As String
Application.ScreenUpdating = False: Set Sh = Sheets("Data")
Zz = Sh.[b65500].End(xlUp).Row
If Not Intersect(Target, [d3]) Is Nothing Then
Range("B7:B" & Zz).EntireRow.Delete
Set Rng = Sh.Range(Sh.[i1], Sh.Cells(Zz, "i"))
Sh.Cells(Zz + 1, "i") = 0
Set sRng = Rng.Find(Format(Target.Value, "Short Date"), , xlFormulas)
If Not sRng Is Nothing Then
jRw = sRng.End(xlDown).Row - sRng.Row
Set Rng = [b65500].End(xlUp).Offset(1, -1)
Rng.Resize(jRw, 13).Value = sRng.Offset(, -8).Resize(jRw, 13).Value
If jRw > 1 Then
For Zz = 1 To 13
Rng.Offset(, Zz - 1).Resize(jRw).Select
With Selection
.VerticalAlignment = xlCenter
If Zz <> 2 And Zz <> 7 Then .MergeCells = True
End With
Next Zz
End If: End If
Sh.Cells(Zz + 1, "i") = "": [d2].Select
' * * * * * * * * * *'
ElseIf Not Intersect(Target, [d4]) Is Nothing Then
Range("B7:B" & Zz).EntireRow.Delete
Set Rng = Sh.Range(Sh.[M1], Sh.Cells(Zz, "M"))
Sh.Cells(Zz + 1, "M") = "@"
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
jRw = sRng.End(xlDown).Row - sRng.Row
Set cRng = [b65500].End(xlUp).Offset(1, -1)
cRng.Resize(jRw, 13).Value = sRng.Offset(, -12).Resize(jRw, 13).Value
If jRw > 1 Then
For Zz = 1 To 13
cRng.Offset(, Zz - 1).Resize(jRw).Select
With Selection
.VerticalAlignment = xlCenter
If Zz <> 2 And Zz <> 7 Then .MergeCells = True
End With
Next Zz
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Sh.Cells(Zz + 1, "M") = "": [d2].Select
End If
Exit Sub
LoiWCh: End Sub
