Const m1r1 = "C11:AC15", m1r2 = "C17:AC20"
Const m2r1 = "B11:T11", m2r2 = "N11"
Const m5r1 = "B11:P11"
Const m6r1 = "D12:Y15", m6r2 = "D17:Y17"
Const m7r1 = "B8:V8"
Const fPath = "C:\PC THCS IA PA\NAM 2010\*"
Dim sM1 As Worksheet, sM2 As Worksheet, sM5 As Worksheet, sM6 As Worksheet, sM7 As Worksheet
Dim r1M1 As Range, r2M1 As Range, r1M2 As Range, r2M2 As Range, r1M5 As Range
Dim r1M6 As Range, r2M6 As Range, r1M7 As Range, rT1 As Range, rT2 As Range
Dim sM1x As Worksheet, sM2x As Worksheet, sM5x As Worksheet, sM6x As Worksheet, sM7x As Worksheet
Dim r1M1x As Range, r2M1x As Range, r1M2x As Range, r2M2x As Range, r1M5x As Range
Dim r1M6x As Range, r2M6x As Range, r1M7x As Range
Dim wbTH As Workbook
Dim a1M1(), a2M1(), a1M6(), a2M6()
Private Sub setVar(wb As Workbook)
With wb
Set sM1 = .Sheets("Mau 1")
Set r1M1 = sM1.Range(m1r1)
Set r2M1 = sM1.Range(m1r2)
Set sM2 = .Sheets("Mau 2")
Set r1M2 = sM2.Range(m2r1)
Set r2M2 = sM2.Range(m2r2)
Set sM5 = .Sheets("Mau 5")
Set r1M5 = sM5.Range(m5r1)
Set sM6 = .Sheets("Mau 6")
Set r1M6 = sM6.Range(m6r1)
Set r2M6 = sM6.Range(m6r2)
Set sM7 = .Sheets("Mau 7 ")
Set r1M7 = sM7.Range(m7r1)
End With
End Sub
Private Sub setVarTH()
With ThisWorkbook
On Error Resume Next
For Each sh In ThisWorkbook.Worksheets
sh.Unprotect ("")
Next
Set sM1x = .Sheets("Mau 1")
Set r1M1x = sM1x.Range(m1r1)
Set r2M1x = sM1x.Range(m1r2)
Set sM2x = .Sheets("Mau 2")
Set r1M2x = sM2x.Range("A10")
Set sM5x = .Sheets("Mau 5")
Set r1M5x = sM5x.Range("A10")
Set sM6x = .Sheets("Mau 6")
Set r1M6x = sM6x.Range(m6r1)
Set r2M6x = sM6x.Range(m6r2)
Set sM7x = .Sheets("Mau 7 ")
Set r1M7x = sM7x.Range("A8")
End With
End Sub
Private Sub copyData()
For i = 1 To 5
For j = 1 To 27
a1M1(i, j) = a1M1(i, j) + r1M1(i, j)
Next
Next
For j = 1 To 27
a2M1(1, j) = a2M1(1, j) + r2M1(1, j)
Next
For i = 1 To 4
For j = 1 To 22
a1M6(i, j) = a1M6(i, j) + r1M6(i, j)
Debug.Print a1M6(i, j)
Next
Next
For j = 1 To 22
a2M6(1, j) = a2M6(1, j) + r2M6(1, j)
Next
r1M2x.Rows(2).EntireRow.Insert
r1M2.Offset(0, 0).Copy: r1M2x.Offset(1, 1).PasteSpecial (xlPasteValues)
r1M5x.Rows(2).EntireRow.Insert
r1M5.Copy: r1M5x.Offset(1, 1).PasteSpecial (xlPasteValues)
r1M7x.Rows(2).EntireRow.Insert
r1M7.Copy: r1M7x.Offset(1, 1).PasteSpecial (xlPasteValues)
End Sub
Private Sub sumData()
Dim sh As Worksheet
r1M1x = a1M1: r2M1x = a2M1
r1M6x = a1M6: r2M6x = a2M6
Call proSheet(2, r1M2x)
Call proSheet(5, r1M5x)
Call proSheet(7, r1M7x)
For Each sh In ThisWorkbook.Worksheets
sh.Protect ("")
Next
End Sub
Private Function setRange(ra As Range) As Range
On Error Resume Next
Set setRange = ra.Offset(1).Resize(ra.End(xlDown).Row - ra.Row - 1, 1)
End Function
Private Sub delData(ra As Range)
Dim t As Range
Set t = setRange(ra)
If Not t Is Nothing Then t.Rows.EntireRow.Delete
End Sub
Private Sub proSheet(m As Long, ra As Range)
Dim t As Range, i As Long
Set t = setRange(ra)
If Not t Is Nothing Then
t.Columns(1).Value = Evaluate("Row(1:" & t.Rows.Count & ")")
ra.End(xlDown).Offset(0, 2).Resize(1, ra.End(xlToRight).Column - 2).Formula = _
"=Sum(" & t.Columns(3).Address(False, False) & ")"
Select Case m
Case 2
With t.Resize(t.Rows.Count + 1)
.Columns(5).Formula = "=If(C11<>0,Round(D11/C11 %,2),"""")"
.Columns(10).Formula = "=If(F11<>0,Round(I11/F11 %,2),"""")"
.Columns(13).Formula = "=If(K11<>0,Round(L11/K11 %,2),"""")"
.Columns(19).Formula = "=If(O11<>0,Round(S11/O11 %,2),"""")"
End With
With ra.End(xlDown)
.Offset(0, 13).Formula = "=Average(" & t.Columns(14).Address(False, False) & ")"
.Offset(0, 19).Value = t(1, 20)
For i = 1 To t.Rows.Count - 1
If InStr(t(i, 20), "ng") Then .Offset(0, 19).Value = t(i, 20)
Next
End With
Case 5
With t.Resize(t.Rows.Count + 1)
.Columns(5).Formula = "=Round(D11/C11 %,2)"
.Columns(7).Formula = "=Round(F11/C11 %,2)"
.Columns(9).Formula = "=Round(H11/C11 %,2)"
.Columns(11).Formula = "=Round(J11/C11 %,2)"
.Columns(13).Formula = "=Round(C11/L11,2)"
.Columns(15).Formula = "=Round(N11/L11,2)"
.Cells(t.Rows.Count + 1, 16).Value = ""
End With
Case 7
With ra.End(xlDown)
.Offset(0, 3).Formula = "=Average(" & t.Columns(4).Address(False, False) & ")"
End With
End Select
End If
End Sub
Sub proFile()
Dim fd As FileDialog
Dim wb As Workbook, sh As Worksheet, ra As Range, shT As Worksheet, ra1 As Range
Dim idx As Long
Dim vrtSelectedItem As Variant
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
ReDim a1M1(1 To 5, 1 To 27)
ReDim a2M1(1 To 1, 1 To 27)
ReDim a1M6(1 To 4, 1 To 22)
ReDim a2M6(1 To 1, 1 To 22)
idx = 1
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
'Allow the selection of multiple file.'
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "XLS", "*.XLS"
.InitialFileName = fPath
If .Show = -1 Then
Call setVarTH
Call delData(r1M2x)
Call delData(r1M5x)
Call delData(r1M7x)
For Each vrtSelectedItem In .SelectedItems
Set wb = Workbooks.Open(vrtSelectedItem)
Call setVar(wb)
Call copyData
wb.Close savechanges:=False
Next vrtSelectedItem
Call sumData
sM1x.Activate
Else
End If
End With
Set fd = Nothing
Set wb = Nothing
Erase a1M1, a2M1, a1M6, a2M6
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
