Giúp Đỡ sửa VBA thêm điều kiện trích dữ liệu theo ngày muốn chọn

Chia sẻ bởi:hands

★★★★★

‹ Tách dữ liệu trong một ô thành... Reminder ??? ›

Quảng cáo

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)
2023

–> 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.

2022

_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("A4:D200").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!

Không cần sheet trung gian. Kiểm tra lại

Option Explicit
Sub XYZ()
  Dim arr(), resDT$(), res(), wb As Workbook, sh As Worksheet, dic As Object
  Dim sRow&, i&, k&, ik&, DT$, fDay&, eDay&, tDay

Set sh = ThisWorkbook.Worksheets("Tach KH")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  fDay = sh.Range("G2").Value
  eDay = sh.Range("H2").Value
  If fDay = Empty Or eDay = Empty Or fDay > eDay Then
    MsgBox ("Dieu kien ngay khong chuan !")
    Exit Sub
  End If
'Gan du lieu vao mang arr
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "DuLieu." & sh.Range("F1").Value)
  arr = Range("D10", Range("G" & Rows.Count).End(xlUp)).Value
  wb.Close False
  If Err.Number > 0 Then
    MsgBox ("File du lieu khong ton tai !")
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
  End If
  On Error GoTo 0
'Loc du lieu
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 3)
  ReDim resDT(1 To sRow, 1 To 1)
  For i = 1 To sRow
    If TypeName(arr(i, 1)) = "String" Then
      tDay = CLng(Split(arr(i, 1), "/")(0))
    Else
      tDay = Day(arr(i, 1))
    End If
    If tDay >= fDay And tDay <= eDay Then
      DT = Trim(arr(i, 4))
      If Not dic.exists(DT) Then
        k = k + 1
        dic.Add DT, k
        res(k, 1) = arr(i, 2):        res(k, 3) = 1
        resDT(k, 1) = arr(i, 4)
      Else
        ik = dic.Item(DT)
        res(ik, 3) = res(ik, 3) + 1
      End If
    End If
  Next i
'Xoa vung ket qua
  i = sh.Range("B" & Rows.Count).End(xlUp).Row
  If i > 3 Then sh.Range("A4:D" & i).ClearContents
'Gan ket qua
  sh.Range("B4").Resize(k, 3) = res
  sh.Range("C4").Resize(k) = resDT
  sh.Range("B4").Resize(k, 3).Sort Key1:=sh.Range("D4"), Order1:=xlDescending
  sh.Range("A4") = 1
  sh.Range("A4").Resize(k).DataSeries
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-%C4%90%E1%BB%A1-s%E1%BB%ADa-vba-th%C3%AAm-%C4%91i%E1%BB%81u-ki%E1%BB%87n-tr%C3%ADch-d%E1%BB%AF-li%E1%BB%87u-theo-ng%C3%A0y-mu%E1%BB%91n-ch%E1%BB%8Dn.163881/#post-1093331

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học

★★★★★ 5 ★ 1 👤 2 ▥ 0

‹ Tách dữ liệu trong một ô thành nhiều... Reminder ??? ›

Quảng cáo

Bạn nên đọc

2 Responses

hands says:

17/01/2023 at 3:51 pm

Mình không biết lập trình VBA, cũng không đọc hiểu code bạn HieuCD nên chỉnh chỗ này báo lỗi chỗ kia, sáng giờ đứng hình luôn chưa làm được gì cả.

Hiện giờ còn 2 cái chưa xử lý xong
+Điều kiện từ ô D10 thay thành ô AO10, còn liên quan gì phía sau nên chỉ sừa D10 thành AO10 thì không chạy được
2026

+Với đúng điều kiện chọn ngày ở trên thì copy hết dữ liệu qua sheet Data để mình còn tạo thêm các Sheet thống kê khác.
Chân thành cảm ơn!

Chỉnh lại . . . .

Option Explicit
Sub XYZ()
  Dim arr(), resDT$(), res(), wb As Workbook, sh As Worksheet, dic As Object
  Dim sRow&, i&, k&, ik&, DT$, fDay&, eDay&, tDay

Set sh = ThisWorkbook.Worksheets("Tach KH")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  fDay = sh.Range("G2").Value
  eDay = sh.Range("H2").Value
  If fDay = Empty Or eDay = Empty Or fDay > eDay Then
    MsgBox ("Dieu kien ngay khong chuan !")
    Exit Sub
  End If
'Gan du lieu vao mang arr
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "DuLieu." & sh.Range("F1").Value)
  arr = Range("A10:AS" & Range("E" & Rows.Count).End(xlUp).Row).Value
  wb.Close False
  If Err.Number > 0 Then
    MsgBox ("File du lieu khong ton tai !")
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
  End If
  On Error GoTo 0
  sRow = UBound(arr)
'Gan du lieu vao sheet Data
  With Sheets("Data")
    If .Range("B2").Value <> Empty Then .Range("B2").CurrentRegion.Offset(1).ClearContents
    .Range("D2").Resize(sRow).NumberFormat = "@"
    .Range("AO2").Resize(sRow).NumberFormat = "@"
    .Range("A2").Resize(sRow, UBound(arr, 2)) = arr
  End With
'Loc du lieu
  ReDim res(1 To sRow, 1 To 3)
  ReDim resDT(1 To sRow, 1 To 1)
  For i = 1 To sRow
    If TypeName(arr(i, 41)) = "String" Then
      tDay = CLng(Split(arr(i, 41), "/")(0))
    Else
      tDay = Day(arr(i, 41))
    End If
    If tDay >= fDay And tDay <= eDay Then
      DT = Trim(arr(i, 7))
      If Not dic.exists(DT) Then
        k = k + 1
        dic.Add DT, k
        res(k, 1) = arr(i, 5):        res(k, 3) = 1
        resDT(k, 1) = DT
      Else
        ik = dic.Item(DT)
        res(ik, 3) = res(ik, 3) + 1
      End If
    End If
  Next i
'Xoa vung ket qua
  i = sh.Range("B" & Rows.Count).End(xlUp).Row
  If i > 3 Then sh.Range("A4:D" & i).ClearContents
'Gan ket qua
  sh.Range("B4").Resize(k, 3) = res
  sh.Range("C4").Resize(k) = resDT
  sh.Range("B4").Resize(k, 3).Sort Key1:=sh.Range("D4"), Order1:=xlDescending
  sh.Range("A4") = 1
  sh.Range("A4").Resize(k).DataSeries
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

hands says:

29/01/2023 at 3:02 pm

Cảm ơn bạn HieuCD rất nhiều, sheet thống kê "Tach KH" chạy đúng rồi ạ, tổng dữ liệu mình có 30 dòng (5 ngày 13, 7 ngày 14-1, 13 ngày 15-1 và 5 ngày 16-1)
nhưng sheet "Data" không phải chép toàn bộ 30 dòng mà chỉ copy tương ứng số liệu bên sheet "Tach KH" thôi. VD: mình bấm chọn ngày đầu 13 và ngày cuối 14 thì sheet Data chép qua 12 dòng tương ứng.

Một lần nữa cảm ơn bạn, chúc bạn và gia đình năm mới vui vẻ tràn đầy niềm vui rộn ràng hạnh phúc, không biết chữ CD cuối nickname có phải viết tắt của châu đốc ko, mình dân châu đốc, thanks!
2473
Nhờ bác chỉnh lại code giúp mình, còn 1 tí chỗ sheet data nữa là mình áp dụng đc rồi, cảm ơn bác HieuCD nhiều!

CD là tên 1 huyện của Long An

Option Explicit
Sub XYZ()
  Dim arr(), resDT$(), res(), wb As Workbook, sh As Worksheet, dic As Object
  Dim sRow&, sCol&, j&, i&, r&, k&, ik&, DT$, fDay&, eDay&, tDay

Set sh = ThisWorkbook.Worksheets("Tach KH")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  fDay = sh.Range("G2").Value
  eDay = sh.Range("H2").Value
  If fDay = Empty Or eDay = Empty Or fDay > eDay Then
    MsgBox ("Dieu kien ngay khong chuan !")
    Exit Sub
  End If
'Gan du lieu vao mang arr
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "DuLieu." & sh.Range("F1").Value)
  arr = Range("A10:AS" & Range("E" & Rows.Count).End(xlUp).Row).Value
  wb.Close False
  If Err.Number > 0 Then
    MsgBox ("File du lieu khong ton tai !")
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
  End If
  On Error GoTo 0
  sRow = UBound(arr): sCol = UBound(arr, 2)
'Loc du lieu
  ReDim res(1 To sRow, 1 To 3)
  ReDim resDT(1 To sRow, 1 To 1)
  For i = 1 To sRow
    If TypeName(arr(i, 41)) = "String" Then
      tDay = CLng(Split(arr(i, 41), "/")(0))
    Else
      tDay = Day(arr(i, 41))
    End If
    If tDay >= fDay And tDay <= eDay Then
      r = r + 1
      If i <> r Then
        For j = 1 To sCol
          arr(r, j) = arr(i, j)
        Next j
      End If
      DT = Trim(arr(i, 7))
      If Not dic.exists(DT) Then
        k = k + 1
        dic.Add DT, k
        res(k, 1) = arr(i, 5):        res(k, 3) = 1
        resDT(k, 1) = DT
      Else
        ik = dic.Item(DT)
        res(ik, 3) = res(ik, 3) + 1
      End If
    End If
  Next i
'Gan du lieu vao sheet Data
  With Sheets("Data")
    If .Range("B2").Value <> Empty Then .Range("B2").CurrentRegion.Offset(1).ClearContents
    .Range("D2").Resize(r).NumberFormat = "@"
    .Range("AO2").Resize(r).NumberFormat = "@"
    .Range("A2").Resize(r, sCol) = arr
  End With
'Xoa vung ket qua
  i = sh.Range("B" & Rows.Count).End(xlUp).Row
  If i > 3 Then sh.Range("A4:D" & i).ClearContents
'Gan ket qua
  sh.Range("B4").Resize(k, 3) = res
  sh.Range("C4").Resize(k) = resDT
  sh.Range("B4").Resize(k, 3).Sort Key1:=sh.Range("D4"), Order1:=xlDescending
  sh.Range("A4") = 1
  sh.Range("A4").Resize(k).DataSeries
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub