Option Explicit
Sub GPE()
Const mCol As Long = 13 'côt A - M'
Dim wsName, sName As String, ws As Worksheet, Cll As Range, arr, lR As Long, ws0 As Worksheet, oldCal
Set ws0 = Total
wsName = Array("01", "02", "03", "04", "05") 'Danh sách tên sheets cân tong hop'
oldCal = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
sName = ws.Name
If CheckName(wsName, sName) = True Then
If sName = "01" Then
Set Cll = ws.Range("A1")
Else
Set Cll = ws.Range("A5")
End If
arr = GetValue(ws, Cll, mCol)
If arr(3) = True Then
lR = ws0.Range("A" & Rows.Count).End(xlUp).Row
If lR > 1 Then lR = lR + 1
ws0.Range("A" & lR).Resize(arr(2), mCol) = arr(1)
End If
End If
Next ws
Application.Calculation = oldCal
Application.ScreenUpdating = False
End Sub
Private Function GetValue(ByVal ws As Worksheet, ByVal Cll As Range, mCol As Long) As Variant
'Cll - cell dâu tiên cua vùng du liêu cân lây
'mcol - sô côt cân lây tinh tu Cll
Dim a, arr(), mR As Long, i As Long, N As Long, flag As Boolean
Dim Res(1 To 3)
mR = LastRow(ws, Cll.Column)
If mR < Cll.Row Then
flag = False
Res(3) = flag
Else
flag = True
With ws
a = .Range(Cll, .Cells(mR, Cll.Column + mCol)).Value2
End With
If IsArray(a) = False Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = a
Else
arr = a
End If
Res(1) = arr
Res(2) = UBound(arr, 1)
Res(3) = flag
End If
GetValue = Res
End Function
Function LastRow(ByVal ws As Worksheet, ByVal sCol As Long) As Long
ShowAllRows ws
LastRow = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row
End Function
Sub ShowAllRows(ByVal ws As Worksheet)
If ws.FilterMode = True Then ws.ShowAllData
ws.Cells.EntireRow.Hidden = False
End Sub
Private Function CheckName(ByVal arr, ByVal sTxt As String) As Boolean
'arr: mang môt chiêu liêt kê tên các sheets
Dim bchk
bchk = Application.Match(sTxt, arr, 0)
If TypeName(bchk) = "Error" Then CheckName = False Else CheckName = True
End Function
