Em chào Anh, Chị
Rất cảm ơn mọi người đã nhiệt tình hỗ trợ ạ
Qua Topic này, em đã nhận được kết quả như mong muốn của một "người lạ" ạ.
Em xin chia sẽ Code để mọi người tham khảo nhé!
Option Explicit
Option Private Module
Public Sub Load_File_Data()
Dim FOb As Object, fso As Object, Item, Path As String, Rw As Long, CotMax, lR As Long
Dim NgayN, MaN, TenN, sArr, dArr, I As Long, K As Long, J As Long, Home
Dim WsM As Worksheet, Ws As Worksheet, Wb As Workbook, Stt
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
On Error Resume Next
CotMax = 11
Set WsM = ActiveSheet
WsM.ShowAllData
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True 'False
.Filters.Add "Microsoft Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban chua chon File", vbInformation, "???"
Exit Sub
End If
'Set DicR = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To 100000, 1 To CotMax)
For Each Item In .SelectedItems
If Left(Item, 1) <> "~" Then
Set Wb = Workbooks.Open(Item)
'For Each Ws In Wb.Worksheets
Set Ws = Wb.Sheets(1)
Ws.ShowAllData
lR = Ws.Range("B" & Rows.Count).End(3).Row
sArr = Ws.Range("B22:B" & lR).Resize(, 8).Value
Stt = Stt + 1
For I = 1 To UBound(sArr)
If Len(sArr(I, 1)) Then
K = K + 1
dArr(K, 1) = Stt
dArr(K, 2) = Trim(Mid(Ws.Range("I1").Value, 6, 200))
dArr(K, 3) = CDate(Mid(Ws.Range("I2").Value, 7, 10))
dArr(K, 4) = Mid(Ws.Range("A7").Value, 5, 500)
dArr(K, 5) = sArr(I, 1)
dArr(K, 6) = sArr(I, 2)
dArr(K, 7) = sArr(I, 3)
dArr(K, 8) = Val(sArr(I, 4))
dArr(K, 9) = Val(sArr(I, 5))
dArr(K, 10) = Val(sArr(I, 6))
dArr(K, 11) = sArr(I, 7)
End If
Next
'Next
Wb.Close
End If
Next
End With
lR = WsM.Range("B" & Rows.Count).End(3).Row
If lR > 3 Then
With WsM
With .Range("B4:B" & lR).Resize(, CotMax)
.ClearContents
.Borders.LineStyle = 0
End With
End With
End If
If K Then
With WsM
.Range("B4").Resize(K, CotMax).Value = dArr
.Range("B3").Resize(K + 1, CotMax).Borders.Color = RGB(192, 192, 192)
End With
End If
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
