Mình đang có code lấy hết dữ liệu từ file dulieu.xlsx chép qua file Trich DuLieu TheoNgay bằng cách vào Sheet Tach KH, bấm nút VIP.
Hiện do cơ chế thay đổi, mình muốn thêm điều kiện để chỉ chép dữ liệu ở file dulieu.xlsx theo Ngày mong muốn (định dạng 15/01/2023 18:27:29, cột AO, đang tô màu vàng)
--> Cách sử dụng là điền ngày bằng số vào ô G2 và ngày cuối vào ô H2, như hình là muốn lấy dữ liệu từ ngày 14, ngày 15 đến ngày 16.
_Code VBA nút VIP như sau:
Cảm ơn mọi người rất nhiều!
Hiện do cơ chế thay đổi, mình muốn thêm điều kiện để chỉ chép dữ liệu ở file dulieu.xlsx theo Ngày mong muốn (định dạng 15/01/2023 18:27:29, cột AO, đang tô màu vàng)
--> Cách sử dụng là điền ngày bằng số vào ô G2 và ngày cuối vào ô H2, như hình là muốn lấy dữ liệu từ ngày 14, ngày 15 đến ngày 16.
_Code VBA nút VIP như sau:
Option Explicit
Sub Loc_VIP()
Dim Data(), DSKH(), KQ()
Dim i&, K&, Rws&, DT$, MyPath$, Duoi$
Dim Dic As Object
Dim OWB As Workbook
Dim TKH As Worksheet
Dim Data1 As Worksheet
'-----------------------------------------------------------------------------------------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
MyPath = ThisWorkbook.Path
Set TKH = ThisWorkbook.Worksheets("Tach KH")
Set Data1 = ThisWorkbook.Worksheets("DaTa")
Data1.Rows("1:50000").Delete
Duoi = TKH.Range("F1").Value
Set OWB = Workbooks.Open(MyPath & "\" & "DuLieu." & Duoi)
OWB.ActiveSheet.Range("A9:BE" & OWB.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Copy
Data1.Range("A1").PasteSpecial
Application.CutCopyMode = False
OWB.Close False
'---------------------------------------------------------------------------------
Set Dic = CreateObject("Scripting.Dictionary")
With Data1
Data = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 57).Value
ReDim DSKH(1 To UBound(Data), 1 To 3)
For i = 1 To UBound(Data)
DT = Trim(Data(i, 7))
If Not Dic.exists(DT) Then
K = K + 1
Dic.Add DT, K
DSKH(K, 1) = Data(i, 5)
DSKH(K, 2) = "'" & Data(i, 7)
DSKH(K, 3) = 1
Else
Rws = Dic.Item(DT)
DSKH(Rws, 3) = DSKH(Rws, 3) + 1
End If
Next
.Range("BI2").Resize(K, 3) = DSKH
.Range("BI2").Resize(K, 3).Sort Key1:=.Range("BK2"), Order1:=xlDescending
'-------------------------------------------------------------------------------------------------------------
ReDim DSKH(1 To 100, 1 To 3)
ReDim KQ(1 To 100, 1 To 4)
DSKH = .Range("BI2:BK150").Value
.Range("BI2").Resize(K, 3).ClearContents
Dic.RemoveAll
K = 0
For i = 1 To 100
DT = DSKH(i, 2)
If Not Dic.exists(DT) And DT <> "" Then
K = K + 1
Dic.Add DT, DSKH(i, 3)
KQ(K, 1) = K
KQ(K, 2) = DSKH(i, 1)
KQ(K, 3) = "'" & DSKH(i, 2)
KQ(K, 4) = DSKH(i, 3)
End If
Next
End With
With TKH
.Range("A4200").ClearContents
.Range("A4").Resize(K, 4) = KQ
.Range("A4").Resize(K, 4).Borders.LineStyle = 1
.Range("C4:C" & .Range("C" & Rows.Count).End(xlUp).Row).Name = "SDT"
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Cảm ơn mọi người rất nhiều!
