Option Explicit
Sub LayLoaiCay()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim ShName As String, SoSh As Byte, iSh As Byte
Dim iR As Long, Er As Long, EndR As Long, SoDong As Long, nR As Long
Dim Data As Range
Sheet9.Select
[V2:AA1000].ClearContents
[D4:O5].ClearContents
[A6:R1000].ClearContents
SoSh = Worksheets.Count
For iSh = 1 To SoSh
ShName = Trim(Sheets(iSh).Name)
If Left(ShName, 1) = "E" Then
nR = nR + 1
With Sheets(iSh)
Er = Sheet9.[W65000].End(xlUp).Row
EndR = .[B65000].End(xlUp).Row - 1
SoDong = EndR - 14
Range("W" & Er + 1 & ":X" & Er + SoDong).Value = .Range("B15:C" & EndR).Value 'Lay loai cay
Range("Y" & Er + 1 & ":Y" & Er + SoDong).Value = .Range("E15:E" & EndR).Value 'Lay so luong
Range("V" & Er + 1 & ":V" & Er + SoDong).Value = ShName 'Lay ma HS
Range("A" & 5 + nR).Value = nR 'STT
Range("B" & 5 + nR).Value = ShName 'MaHS
Range("C" & 5 + nR).Value = .[C6] 'Ten HS
End With
End If
Next
Set Data = Range("V1:Y" & Er + SoDong)
With Data
.Sort Key1:=Range("V1"), Order1:=xlAscending, Key2:=Range("W1"), Order1:=xlAscending, Key3:=Range("X1"), Order1:=xlAscending, Header:=xlYes
End With
Set Data = Range("W1:X" & Er + SoDong)
With Data
.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"Z1:AA1"), Unique:=True
End With
'tao name de dung sumproduct
Range("V2:V" & Er + SoDong).Name = "MaHS"
Range("V2:V" & Er + SoDong).Offset(, 1).Name = "Cay"
Range("V2:V" & Er + SoDong).Offset(, 2).Name = "Loai"
Range("V2:V" & Er + SoDong).Offset(, 3).Name = "Slg"
EndR = [Z65000].End(xlUp).Row
Set Data = Range("Z2:AA" & EndR)
For iR = 1 To EndR
'If Data.Cells(iR, 1) <> Data.Cells(iR - 1, 1) Then
Cells(4, 4 + iR - 1) = Data.Cells(iR, 1)
'End If
Cells(5, 4 + iR - 1) = Data.Cells(iR, 2)
Next
'Gan soluong theo cay trong
Range(Cells(6, 4), Cells(5 + nR, 2 + EndR)).FormulaR1C1 = "=SUMPRODUCT((MaHS=RC2)*(Cay=R4C)*(Loai=R5C)*(Slg))"
Range(Cells(6, 4), Cells(5 + nR, 2 + EndR)).Value = Range(Cells(6, 4), Cells(5 + nR, 2 + EndR)).Value
'***/Xoa name
With Sheet9
.Names("Extract").Delete
End With
ActiveWorkbook.Names("Mahs").Delete
ActiveWorkbook.Names("Cay").Delete
ActiveWorkbook.Names("Loai").Delete
ActiveWorkbook.Names("SLg").Delete
Set Data = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
