Sub QuaLungTung()
Dim sArr(), Res()
Dim sRow&, fRow&, eRow&
Dim i&, i2&, k&, c&, j&, j2&, jC&
Const size$ = "Size range"
With Sheets("Sheet1")
sArr = .Range("A2:AE" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
sRow = UBound(sArr)
ReDim Res(1 To sRow, 1 To 3)
For i = 1 To sRow
If sArr(i, 1) = size Or sArr(i, 2) = size Then
fRow = 0
For i2 = i + 1 To sRow
If (sArr(i2, 1) <> Empty Or sArr(i2, 2) <> Empty) And fRow = 0 Then fRow = i2
If sArr(i2, 1) = Empty And sArr(i2, 2) = Empty And fRow > 0 Then
eRow = i2 - 1: Exit For
End If
Next i2
For c = 3 To 30
If sArr(i, c) = "outcarton dimension" Then
For j = c + 1 To 30
If sArr(i, j) = "Cartons" Then
jC = j: Exit For
End If
Next j
For i2 = fRow To eRow
If sArr(i2, c) <> Empty Or sArr(i2, c - 1) <> Empty Then
k = k + 1
Res(k, 1) = sArr(i2, 31)
If sArr(i2, c) = Empty Then
Res(k, 2) = sArr(i2, c - 1)
Else
Res(k, 2) = sArr(i2, c)
End If
Res(k, 3) = sArr(i2, jC)
End If
Next i2
ElseIf sArr(i, c) = "Empty Innerbox dimension" Then
For j = c + 1 To 30
If sArr(i, j) Like "Total?" Then
jC = j: Exit For
End If
Next j
For i2 = fRow To eRow
If sArr(i2, c) <> Empty Then
k = k + 1
Res(k, 1) = sArr(i2, 31)
Res(k, 2) = sArr(i2, c)
For j = c + 1 To 20
If Len(sArr(i2, j)) Then
Res(k, 3) = sArr(i2, j): Exit For
End If
Next j
End If
Next i2
Exit For
End If
Next c
i = eRow
End If
Next i
With Sheets("Ket qua")
i = .Range("A" & Rows.Count).End(xlUp).Row
If i > 1 Then .Range("A2:C" & i).ClearContents
If k Then .Range("A2").Resize(k, 3) = Res
End With
End Sub
