Option Explicit
Sub Bsung()
Dim Lr&, i&, J&, R&, t&, TongN&, Vitri&, tt&, kk&
Dim Arr(), KQ(), NCC(), ntn(1 To 3), e, N
Dim fso As Object, Dic As Object, DicT As Object
Dim NWs As Worksheet, WbMoi As Workbook, Ws As Worksheet
Dim Keys As String
Dim file As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dic = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
ReDim NCC(1 To 100, 1 To 3)
Sheets("DMHH").Select
For J = 1 To Sheets("DMHH").Cells(Rows.Count, 1).End(xlUp).Row
Keys = Sheets("DMHH").Cells(J, 1)
If Not Dic.exists(Keys) Then
t = t + 1: Dic.Add (Keys), t
NCC(t, 1) = Keys
NCC(t, 2) = Sheets("DMHH").Cells(J, 2)
NCC(t, 3) = Sheets("DMHH").Cells(J, 3)
End If
Next J
ReDim KQ(1 To 100, 1 To 1)
For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\").Files
If file.Name Like "*Excel5.xls" Then
Set WbMoi = Workbooks.Open(file) '======Bi lôi dong này "không tim thây, có thê đa đôi ten, di chuyên hoac đa xoa"
For Each Ws In WbMoi.Sheets
If Ws.Name = "TPT" Then
Set DicT = CreateObject("Scripting.Dictionary")
'=======Copy sheet nguon=========='
Ws.Select
Ws.Range("A1:Q30").Copy
'=========paste xuông Sheet============'
Windows("TONGHOP DULIEU NHAP TP (DDMN).xlsm").Activate
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Set NWs = ActiveSheet
WbMoi.Close
'===========tach lay ngay tháng============'
Vitri = 0: kk = 0: tt = 0
For Each e In Split(NWs.Cells(5, 1))
If IsNumeric(e) Then
Vitri = Vitri + 1
ntn(Vitri) = CLng(e)
If Vitri >= 3 Then ' đ? 3 s? r?i, tính ngày
N = DateSerial(ntn(3), ntn(2), ntn(1))
Exit For
End If
End If
Next e
'============Lây dư liêu thay thê bô sung=============='
Lr = NWs.Cells(Rows.Count, 1).End(xlUp).Row
Arr = NWs.Range("A10:O" & Lr).Value
TongN = 0
ReDim KQ(1 To UBound(Arr) + 1, 1 To 15)
For i = 1 To UBound(Arr)
KQ(i, 1) = Arr(i, 1)
KQ(i, 2) = Arr(i, 2)
KQ(i, 3) = Arr(i, 3)
' KQ(i, 4) = 8 & "h" & Int(Application.WorksheetFunction.RandBetween(1, 89) / 3) _
& "p-" & Day(N) & "/" & Month(N)
KQ(i, 5) = Arr(i, 5)
KQ(i, 6) = Arr(i, 6)
KQ(i, 7) = Arr(i, 5) * Arr(i, 6) 'Arr(i, 7) * 1000
TongN = TongN + Arr(i, 7)
KQ(i, 8) = "Đat"
If Dic.exists(Arr(i, 2)) Then
KQ(i, 10) = NCC(Dic.Item(Arr(i, 2)), 2)
KQ(i, 11) = NCC(Dic.Item(Arr(i, 2)), 3)
End If
If Not DicT.exists(KQ(i, 10)) Then
tt = tt + 1: DicT.Add (KQ(i, 10)), tt
KQ(i, 4) = 8 & "h" & Int(Application.WorksheetFunction.RandBetween(1, 89) / 3) _
& "p-" & Day(N) & "/" & Month(N)
Else
kk = DicT.Item(KQ(i, 10))
KQ(i, 4) = KQ(kk, 4)
End If
KQ(i, 13) = KQ(i, 5)
KQ(i, 14) = KQ(i, 6)
KQ(i, 15) = KQ(i, 7)
Next i
Set DicT = Nothing
NWs.Name = "N" & Day(N) & "T" & Month(N)
End If
NWs.Range("A10").Resize(i, 15) = KQ
NWs.Range("A" & Lr + 1, "P" & Lr + 2).Select
Selection.UnMerge
Selection.Font.Size = 10
Selection.Font.Bold = True
Selection.NumberFormat = "#,##0"
'NWs.Range("A" & Lr + 1, "P" & Lr + 2).Font.Size = 10
NWs.Range("B" & Lr + 1) = "Công"
NWs.Range("G" & Lr + 1) = TongN
NWs.Range("O" & Lr + 1) = TongN
NWs.Range("B" & Lr + 2) = "Băng chư:"
NWs.Range("C" & Lr + 2).FormulaR1C1 = "=VND(R[-1]C[4])"
NWs.Range("C" & Lr + 2).HorizontalAlignment = xlLeft
NWs.Range("O10", "O" & Lr).HorizontalAlignment = xlRight
NWs.Range("B" & Lr + 2, "C" & Lr + 2).Font.Italic = True
NWs.Range("B" & Lr + 2, "C" & Lr + 2).Font.Bold = False
NWs.Range("M" & Lr + 2, "Q" & Lr + 2).ClearContents
NWs.Range("A7:P16").Font.Size = 10
NWs.Columns("A:A").ColumnWidth = 2.89
NWs.Columns("B:B").ColumnWidth = 9.78
NWs.Columns("C:C").ColumnWidth = 3.22
NWs.Columns("D:D").ColumnWidth = 8.22
NWs.Columns("E:E").ColumnWidth = 4.5
NWs.Columns("F:F").ColumnWidth = 4.7
NWs.Columns("G:G").ColumnWidth = 8
NWs.Columns("H:H").ColumnWidth = 3.67
NWs.Columns("I:I").ColumnWidth = 3.44
NWs.Columns("J:J").ColumnWidth = 13.2
NWs.Columns("K:K").ColumnWidth = 13
NWs.Columns("L:L").ColumnWidth = 10.11
NWs.Columns("M:M").ColumnWidth = 4.5
NWs.Columns("N:N").ColumnWidth = 4.7
NWs.Columns("O:O").ColumnWidth = 8
NWs.Columns("P:P").ColumnWidth = 7.11
NWs.Range("A1").HorizontalAlignment = xlCenter
NWs.Range("A2").HorizontalAlignment = xlCenter
NWs.Range("A1").VerticalAlignment = xlCenter
NWs.Range("A2").VerticalAlignment = xlCenter
NWs.Range("B10", "B" & Lr).WrapText = True
NWs.Range("B" & Lr + 3).WrapText = False
NWs.Range("F" & Lr + 3).WrapText = False
NWs.Range("B" & Lr + 8).WrapText = False
NWs.Range("F" & Lr + 8).WrapText = False
NWs.Range("D10", "D" & Lr).ShrinkToFit = True
NWs.Range("J10", "L" & Lr).ShrinkToFit = True
Next Ws
End If
Next file
Call MucLuc
Sheets("MucLuc").range("A1").Select
Set fso = Nothing
Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox " Đa hoàn thành lây bô sung dư liêu các phiêu N-X hàng ngày", vbInformation, "THÔNG BÁO"
End Sub
