Sub TongHop()
Dim cn As Object, SQL As String, duonglinh, arr, SMTLineName As String, ketqua, b As Long
Dim FinishedMaterial As String, SubAssyMaterial As String, PCBName As String, SeriesNumber As String, tensheet, s As String
Dim cat As Object, ten, cotg As Long, coth As Double
Dim j As Integer, a As Long, i As Long, lr As Long
Set cat = CreateObject("ADOX.Catalog")
Set cn = CreateObject("ADODB.Connection") 'khai báo cho ADO
Application.ScreenUpdating = False 'Tat cap nhap man hinh
With Sheets("sheet1")
lr = .Range("A" & Rows.Count).End(xlUp).Row 'xác dinh dong cuoi cua bang tong hop
If lr > 1 Then .Range("A2:O" & lr).ClearContents 'neu dong cuoi lon hon 15 thi xoa
End With
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True 'cho chon nhieu file
.Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1 'chi hien cac duoi excel
If Not .Show = -1 Then 'Kiêm tra xem da chon file chua
MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
Exit Sub
End If
For Each duonglinh In .SelectedItems
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & duonglinh & ";Extended Properties=""Excel 12.0;HDR=No"";" ' mo file excel
Set cat.ActiveConnection = cn
' ten = cat.tables.Name
For Each ten In cat.tables
If Right(ten.Name, 1) = "$" Or Right(ten.Name, 2) = "$'" Then
tensheet = Replace(ten.Name, "'", "")
SQL = "SELECT * FROM [" & tensheet & "A3:G3] " 'cau lenh sql de lay du lieu vung
arr = chuyenmang(cn.Execute(SQL).getrows) 'lay du lieu vào mang
'tenshop = arr(1, 2) 'gán vào bien
'mashop = arr(2, 2)
'ngaythang = Format(arr(3, 2), "MM-DD-YYYY")
SMTLineName = Empty: FinishedMaterial = Empty: SubAssyMaterial = Empty: PCBName = Empty: SeriesNumber = Empty
If Not IsNull(arr(1, 1)) Then SMTLineName = arr(1, 1)
If Not IsNull(arr(1, 4)) Then FinishedMaterial = arr(1, 4)
If Not IsNull(arr(1, 5)) Then SubAssyMaterial = arr(1, 5)
If Not IsNull(arr(1, 6)) Then PCBName = arr(1, 6)
If Not IsNull(arr(1, 7)) Then SeriesNumber = arr(1, 7)
SQL = "SELECT * FROM [" & tensheet & "A6:H5000] where f8 is not null" 'cau lênh sql de lay du lieu khác Null o cot A
arr = chuyenmang(cn.Execute(SQL).getrows)
ReDim ketqua(1 To UBound(arr), 1 To 16)
For i = 1 To UBound(arr) - 1 'vong lap for i de chay cac dong
If arr(i, 7) <> "No. of comp.ts" Then
a = a + 1
b = b + 1
ketqua(a, 1) = b 'STT
ketqua(a, 2) = SMTLineName 'SMTLineName
ketqua(a, 3) = FinishedMaterial 'FinishedMaterial
ketqua(a, 4) = SubAssyMaterial 'gan SubAssyMaterial vao mang
ketqua(a, 5) = PCBName 'gan PCBName vao mang
ketqua(a, 6) = SeriesNumber 'gan SeriesNumber vao mang
ketqua(a, 7) = cotg
ketqua(a, 8) = coth
For j = 1 To UBound(arr, 2) 'vong lap for j de chay cac cot
ketqua(a, j + 8) = arr(i, j) 'gan cac gia tri tu mang sang mang
Next j
Else
If IsNull(arr(i, 6)) Then cotg = Empty Else cotg = arr(i, 6)
coth = arr(i, 8)
End If
Next i
End If
Next
With Sheets("sheet1")
lr = .Range("A" & Rows.Count).End(xlUp).Row + 1
If a Then .Range("A" & lr).Resize(a, 16).Value = ketqua
End With
Erase ketqua
a = 0
cn.Close 'dong file
Next
End With
Application.ScreenUpdating = True 'bat cap nhap man hinh
Set cn = Nothing
Set cat = Nothing
End Sub
Private Function chuyenmang(ByVal arr) As Variant
Dim kq(), i As Long, j As Long
ReDim kq(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
For i = LBound(arr, 2) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
kq(i + 1, j + 1) = arr(j, i)
Next j
Next i
chuyenmang = kq
End Function
