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

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài

acrox84

Thành viên hoạt động
Tham gia
22/3/08
Bài viết
101
Được thích
28
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)
cotAO.jpg

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

ShVIP.jpg

_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!
 

File đính kèm

  • dulieu.xlsx
    20.1 KB · Đọc: 8
  • Trich DuLieu TheoNgay.xlsm
    41.4 KB · Đọc: 10
Code VIP ấy lấy ở đâu, hay của ai đó trong GPE viết cho bạn thì đưa thêm chi tiết nơi trích dẫn.

Code ấy có thể viết lâu lắm rồi, không còn thích hợp. Rất có thể, nếu biết đầy đủ mục tiêu thì viết lại code khác dễ hơn.

Cách thiết kế và tra cứu dữ liệu của các bạn phẩn lớn là không theo chuẩn cho nên cốt kiếc công thức này nọ đều là code đặc thù cho trường hợp riêng, sửa vài lần nó thành ra cái tổ đỉa.
 
Upvote 0
Code VIP ấy lấy ở đâu, hay của ai đó trong GPE viết cho bạn thì đưa thêm chi tiết nơi trích dẫn.

Code ấy có thể viết lâu lắm rồi, không còn thích hợp. Rất có thể, nếu biết đầy đủ mục tiêu thì viết lại code khác dễ hơn.

Cách thiết kế và tra cứu dữ liệu của các bạn phẩn lớn là không theo chuẩn cho nên cốt kiếc công thức này nọ đều là code đặc thù cho trường hợp riêng, sửa vài lần nó thành ra cái tổ đỉa.
Code vip ở đây nha bạn,

Mình nhớ lấy code của bạn Cu Tồ sử dụng tới giờ.
 
Upvote 0
Trường hợp điển hình của việc nhờ viết giùm code VBA dễ quá cho nên người ta đâm lười học mấy công cụ khác mà mấy năm nay MS đã cải tiến.
Cái này ngày nay có đến vài cách giải khác, tốt hơn. Chỉ cần đầu óc cởi mở, chịu khó tìm hiểu.
 
Upvote 0
Trường hợp điển hình của việc nhờ viết giùm code VBA dễ quá cho nên người ta đâm lười học mấy công cụ khác mà mấy năm nay MS đã cải tiến.
Cái này ngày nay có đến vài cách giải khác, tốt hơn. Chỉ cần đầu óc cởi mở, chịu khó tìm hiểu.
Cảm ơn đã dành thời gian xem
 
Upvote 0
Cảm ơn đã dành thời gian xem
Trong tất cả giải pháp thì viết code VBA là tay mơ nhất. Tự khoe rằng mình không biết sử dụng các công cụ mới của MS.

Trừ phi dối gạt được với người chung quanh là mình biết code và code ấy do mình viết ra.
 
Lần chỉnh sửa cuối:
Upvote 0
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)
View attachment 285763

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

View attachment 285764

_Code VBA nút VIP như sau:


Cảm ơn mọi người rất nhiều!
Không cần sheet trung gian. Kiểm tra lại
Mã:
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
 
Upvote 0
Không cần sheet trung gian. Kiểm tra lại
Trường hợp này mình cần Sheet trung gian, do còn lấy dữ liệu từ đó thống kê tiếp ở những sheet khác, bạn giữ lại giúp mình với.
Mình thử add code bạn vào file đính kèm ban đầu, thử nhập Ngày đầu: 13, Ngày cuối: 13, thống kê ra 10, mình thử đếm tay thấy có 5 đơn ngày 13 thôi, bạn kiểm tra lại xem phải không.

Công việc của mình không phải dân văn phòng, chỉ biết cơ bản excel, không biết lập trình cho nên khi đụng vấn đề, đều phải lên GPE nhờ vả, cũng may anh chị em diễn đàn GPE đều rất nhiệt tình giúp đỡ, có những code mình sử dụng được hơn 2 năm nay vẫn tốt. Chân thành cảm ơn mọi người!
 

File đính kèm

  • Trich DuLieu TheoNgay2.xlsm
    40.5 KB · Đọc: 5
Upvote 0
Trường hợp này mình cần Sheet trung gian, do còn lấy dữ liệu từ đó thống kê tiếp ở những sheet khác, bạn giữ lại giúp mình với.
Mình thử add code bạn vào file đính kèm ban đầu, thử nhập Ngày đầu: 13, Ngày cuối: 13, thống kê ra 10, mình thử đếm tay thấy có 5 đơn ngày 13 thôi, bạn kiểm tra lại xem phải không.

Công việc của mình không phải dân văn phòng, chỉ biết cơ bản excel, không biết lập trình cho nên khi đụng vấn đề, đều phải lên GPE nhờ vả, cũng may anh chị em diễn đàn GPE đều rất nhiệt tình giúp đỡ, có những code mình sử dụng được hơn 2 năm nay vẫn tốt. Chân thành cảm ơn mọi người!
Bạn tự chỉnh để copy sheet trung gian
Mình đếm có 10 dòng ngày 13
 
Upvote 0
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
AA1.jpg
arr = Range("D10", Range("G" & Rows.Count).End(xlUp)).Value
+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!
 

File đính kèm

  • dulieu.xlsx
    20.1 KB · Đọc: 4
  • Trich DuLieu TheoNgay3.xlsm
    40.5 KB · Đọc: 10
Upvote 0
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
View attachment 285793

+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 . . . .
Mã:
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
 
Upvote 0
Chỉnh lại . . . .
Mã:
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
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!
12b2.jpg
 
Upvote 0
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!
 
Upvote 0
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!
View attachment 285830
CD là tên 1 huyện của Long An
Mã:
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
 
Upvote 0
Cảm ơn bạn HieuCD rất nhiều, code bạn cho giúp ích cho công việc hiện tại của mình mỗi ngày, chúc bạn vui vẻ và thật nhiều may mắn.
 
Upvote 0
Web KT
Back
Top Bottom