Trong khi chờ các giải pháp khác thử code này xem sao
Option Explicit
Sub ABC()
Dim i&, j&, Lr&, t&, k&, d&, R&, Length&
Dim Arr(), KQ()
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("Detail")
Lr = Sh.Cells(Rows.Count, 13).End(xlUp).Row
Arr = Sh.Range("A7:P" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To R
If Arr(i, 3) <> Empty Then
t = t + 1: d = 0: Length = 0: k = i
d = Sh.Cells(i + 6, 13).End(xlDown).Row - 6
KQ(t, 1) = t
KQ(t, 2) = Arr(i, 1)
KQ(t, 3) = Arr(i, 2)
KQ(t, 4) = Arr(i, 3)
For k = i To d
If Arr(k, 7) <> Empty And IsNumeric(Arr(k, 7)) And Arr(k, 7) >= Length Then Length = Arr(k, 7): KQ(t, 5) = Length
Next k
For k = i To d
If Arr(k, 16) <> Empty Then KQ(t, 9) = Arr(k, 16): Exit For
Next k
KQ(t, 6) = Arr(d, 13)
KQ(t, 7) = Arr(d, 14)
KQ(t, 8) = Arr(d, 15)
End If
Next i
Set Ws = Sheets("Summary List")
If t Then
Ws.Range("B4").Resize(50000, 9).Clear
Ws.Range("B4").Resize(t, 9) = KQ
Ws.Range("B4").Resize(t, 9).Borders.LineStyle = 1
End If
MsgBox "Done"
End Sub
Cảm ơn bạn đã chia sẽ, nhưng code sẽ bỏ qua dữ liệu nếu 1 trong 3 ô ở cùng 1 dòng của cột A, B,C trống
Bạn đúng là chuyên gia rồi.
Cảm ơn bạn đã nhắc nhở. Tôi chi xem dữ liệu mấy dòng đầu và mấy dòng cuối, chứ không xem hết phần bên trong.
Thay code cũ bằng code này
Option Explicit
Sub ABC()
Dim i&, j&, Lr&, t&, k&, d&, R&, Length&, A&
Dim Arr(), KQ()
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("Detail")
Lr = Sh.Cells(Rows.Count, 13).End(xlUp).Row
Arr = Sh.Range("A6:P" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R, 1 To 9)
For i = 1 To R
If Arr(i, 1) <> Empty Then
If Not IsNumeric(Mid(Arr(i, 1), 2, 1)) Then
j = j + 1: A = A + 1
KQ(j, 1) = Application.WorksheetFunction.Roman(A)
KQ(j, 2) = Arr(i, 1)
End If
If IsNumeric(Mid(Arr(i, 1), 1, 2)) Then
t = t + 1: j = j + 1: d = 0: Length = 0: k = i
d = Sh.Cells(i + 5, 13).End(xlDown).Row - 5
KQ(j, 1) = t
KQ(j, 2) = Arr(i, 1)
KQ(j, 3) = Arr(i, 2)
KQ(j, 4) = Arr(i, 3)
For k = i To d
If Arr(k, 7) <> Empty And IsNumeric(Arr(k, 7)) And Arr(k, 7) >= Length Then Length = Arr(k, 7): KQ(t, 5) = Length
Next k
For k = i To d
If Arr(k, 16) <> Empty Then KQ(j, 9) = Arr(k, 16): Exit For
Next k
KQ(j, 6) = Arr(d, 13)
KQ(j, 7) = Arr(d, 14)
KQ(j, 8) = Arr(d, 15)
End If
End If
Next i
Set Ws = Sheets("Summary List")
If t Then
Ws.Range("B4").Resize(50000, 9).Clear
Ws.Range("B4").Resize(j, 9) = KQ
Ws.Range("B4").Resize(j, 9).Borders.LineStyle = 1
End If
MsgBox "Done"
End SubCó gì đâu chú. Tại chú code rồi. Cháu có rà lại kết quả của chú thấy có chỗ bất thường. Và bị thiếu nên cháu quay lại kiểm tra dữ liệu thôi ạ
Bạn thay dòng lệnh sau
For k = i To d
If Arr(k, 7) <> Empty And IsNumeric(Arr(k, 7)) And Arr(k, 7) >= Length Then Length = Arr(k, 7): KQ(t, 5) = Length
Next k For k = i To d
If Arr(k, 7) <> Empty And IsNumeric(Arr(k, 7)) And Arr(k, 7) >= Length Then Length = Arr(k, 7): KQ(j, 5) = Length
Next kGía trị sum ở cột I (Total Weight) hiện tại code cho kết quả = 289254.39 nhưng kết quả đúng phải là 289065.26.
