Sub GPE3()
Dim Wb As Workbook, Ws As Worksheet, Master As Worksheet
Dim Item As Variant, lR1 As Long, lR2 As Long
Dim arr, sArr(), dArr(), I As Long, J As Long, Mon As String
Application.ScreenUpdating = False
arr = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31")
Mon = Application.InputBox("Nhap thang va nam", "GPE", Type:=2)
Set Master = ThisWorkbook.Sheets("DATA")
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Add "Microsoft Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban chua chon File", vbCritical, "----Mr.GPE----"
Exit Sub
End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
For Each Ws In Wb.Sheets
If CheckName(arr, Ws.Name) Then
lR1 = Ws.Range("M" & Rows.Count).End(xlUp).Row
Call Xoadong(Ws, "A", 6, lR1)
lR1 = Ws.Range("A" & Rows.Count).End(xlUp).Row
sArr() = Ws.Range("A6").Resize(lR1 - 5, 15).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 15)
For I = 1 To UBound(sArr, 1)
dArr(I, 1) = CDate(Ws.Name & "/" & Mon)
For J = 2 To 15
dArr(I, J) = sArr(I, J)
Next J
Next I
With Master
lR2 = .Range("H" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lR2).Resize(UBound(sArr, 1), 15) = dArr
End With
Erase sArr: Erase dArr
End If
Next Ws
Wb.Close False
Next Item
End With
Set Master = Nothing: Set Wb = Nothing
Application.ScreenUpdating = True
MsgBox "Done", vbInformation, "----Mr.GPE----"
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
Sub Xoadong(Ws As Worksheet, Col As String, eRw As Long, lRw As Long)
Ws.Range(Col & eRw).Resize(lRw - eRw + 1).SpecialCells(xlCellTypeBlanks, 23).EntireRow.Delete
End Sub
