Các bài tập VBA đơn giản dùng để xử lí CSDL (cơ sở dữ liệu) [Fần 3] (3 người xem)

[SA_DQ]

PHẦN GIỚI THIỆU​

Tạo 1 CSDL trong & xử lí nó để fục vụ cho công tác quản lí là nhu cầu có thực đang diễn ra hàng ngày tại các công sở, cơ quan sản xuất kinh doanh, dịch vụ,. . . .
Để tạo dựng nó ta cần thông qua các bước cơ bản sau đây:

Thiết kế: Tạo dựng các trang tính, bảng biểu,. . .

Vận hành: Gồm các công đoạn nhập dữ liệu, chỉnh sửa & làm ra các báo cáo tổng hợp hay chi tiết

Bảo trì & fát triển:

Đầu tiên xin giới thiệu đến các bạn 1 CSDL dùng để nhập hàng hóa từ nhà cung cấp;
Hiện tại trong file đính kèm ta chỉ có 3 trang tính.

Đó là trang "DMuc" sẽ gồm các bảng liệt kê hàng hóa. Thường nó có các trường sau: [TT], [Mã hàng], [Tên hàng], [Đơn vị tính], [Tồn Đầu],. . . .

Thứ đến là trang nhập dữ liệu
Trang này thường có hai fần; Mình tạm gọi là fần chung & fần chi tiết
Fần chung gồm các mục: Ngày tháng, Số fiếu, Nhà cung cấp, Mã NCC,. . . .
Fần chi tiết gồm các mục: [Mã hàng], [Tên hàng], [ĐVT], [Số lượng], [Ghi chú],. . .
Trang này dùng để nhập dữ liệu vô trang CSDL (mà trong file có tên là 'CTiet')

Trang chứa thông tin CSDL ('CTiet')
Trang này gồm 2 bảng; Một bảng chứa những dữ liệu có trong fần chung & 1 bảng chứa dữ liệu fần chi tiết bên trên ta vừa nêu
Một điều hết sức quan trọng là 2 bảng biểu này liên hệ khắng khít với nhau thông qua trường [Số fiếu]

Tác giả file này đã thiết lập qui trình để tạo ra số fiếu này. Chúng được tạo ra theo sự tăng dần của các ngày lập fiếu & trong 1 ngày thì tăng theo thứ tự của 3 kí số cuối.

Các bạn có thể tham khảo thêm các bài viết về CSDL trong excel có trên diễn đàn, chẳng hạn:
http://www.giaiphapexcel.com/forum/showthread.php?6159-Tạo-CSDL-trên-Excel
Nội dung bài tập đầu tiên sẽ có ở bài sau kế tiếp

Chúc vui & hạnh phúc!

 

[SA_DQ]

Ở file đính kèm bên trên ta có trang tính 'Nhap'. Tại ô [C3] trang tính này có cài sẵn 1 macro sự kiện.
Nếu ta nhập 1 ngày nào đó vô ô, macro sẽ đưa cho ta 1 trong 2 kết quả sau:

Nếu ngày đó chưa nhập hàng (chưa có trong cột của trang 'CTiet') thì macro sẽ tự động tạo cho ta mã số fiếu đầu tiên trong ngày

Nếu đã có số liệu nhập hàng ngày hôm í, thì tại cột [H] sẽ xuất hiện danh sách các fiếu nhập trong ngày hôm ấy đã có.

Lúc này bạn sẽ fải tự mình chọn & thêm vô 3 kí số cuối thích hợp để điền vô [C4]
(Ví dụ ở [H2] đang hiển thị 'E29N001', ta nên nhập vô [c4] mã 'E29N002')
Sau đó ta lấp đầy các dòng ở fần chi tiết về [mã hàng] (chỉ cần chọn mã hàng nào đó, 2 cột bên fải tương ứng trong hàng sẽ được hàm VLOOKUP() hỗ trợ bạn nhập liệu;
Bạn cần nhập tiếp số liệu cột [E..F] thuộc dòng để hoàn chỉnh.

Bài tập 1: Như đã có ghi trong trang tính

Chú í: Yêu cầu là nhập 1 lúc vô 2 bảng của trang tính 'CTiet', ở bảng đầu ta chỉ nhập 1 dòng cho mỗi fiếu nhập; Ở bảng còn lại ta chép đủ các dòng của fần chi tiết tương ứng.

Chúc các bạn thành công!

 

[doveandrose]

Nếu ngày đó chưa nhập hàng (chưa có trong cột [A] của trang 'CTiet') thì macro sẽ tự động tạo cho ta mã số fiếu đầu tiên trong ngày

cột A trang CTiet em có thấy gì đâu thầy

 

[SA_DQ]

À, xin lỗi bạn & cộng đồng;
Đúng ra là cột & mình sẽ sửa ở bài trên.

 

[doveandrose]

sự kiện Worksheet_Change có sẵn trong file của thầy em chưa hiểu lắm nên em chưa xài tới được không thầy ?
thay vào đó tại ô C4 em nhập là

C4=IFERROR( LOOKUP(2,1/(LEFT(CTiet!C2:C50000,3)=TaoMa(C3)),TaoMa(C3) & "N" & TEXT( RIGHT(CTiet!C2:C50000,3)+1,"000")),TaoMa(C3) & "N001")

cái nút bấm em xài như vầy

Private Sub MyCmd_Click()
If IsError(Worksheets("Nhap").Range("C4").Value) Then
    MsgBox "Khong hieu dinh dang ngay"
    Exit Sub
End If
Dim arr As Variant, tpArr(1 To 1, 1 To 2) As Variant, ctpArr(1 To 100, 1 To 5) As Variant
Dim n As Integer, r As Integer, c As Integer, lr As Long
With Worksheets("Nhap")
    arr = .Range("B10:E109").Value
    tpArr(1, 1) = .Range("C3").Value2
    tpArr(1, 2) = .Range("C4").Value
End With
For r = 1 To 100 Step 1
    If arr(r, 1) <> "" Then
        n = n + 1
        ctpArr(n, 1) = tpArr(1, 2)
        For c = 2 To 5 Step 1
            ctpArr(n, c) = arr(r, c - 1)
        Next
    End If
Next
If n > 0 Then
    With Worksheets("CTiet")
        lr = .[B50000].End(xlUp).Row + 1
        .Range("B" & lr & ":C" & lr).Value = tpArr
        lr = .[R50000].End(xlUp).Row + 1
        .Range("R" & lr & ":V" & (lr + n - 1)).Value = ctpArr
    End With
    Worksheets("Nhap").Range("B10:B109").ClearContents
    Worksheets("Nhap").Range("E10:E109").ClearContents
End If

 

[doveandrose]

(1) Bạn nên chỉnh lại câu lệnh này:

Worksheets("Nhap").Range("B10:B109").ClearContents

Vì trong Form nhập liệu, tác giả nào đó đã thiết lập 15 ô Validation để tiện nhập liệu;
Lệnh của bạn xóa mất những ô Validation này thì tác giả sẽ cự nự cho mà coi!

(2) Hình như bạn chưa ghi lại ngày lập fiếu vô đâu cả (ở trang 'CTiet') đó nha!
Vì sau này ta tìm cách thống kê theo ngày sẽ rất khó khăn!

em thật sự không hiểu cả 2 điều trên
1/lệnh ClearContents không làm mất Validation List trên cột B trên máy em . em chạy thử rồi mới up bài làm lên chứ
2/câu này càng khó hiểu . em thấy cột B trang Ctiet đã ghi lại ngày của từng phiếu nhập . ý anh là thiếu ngày nào ?
thậm chí là với cách lập hàm taoma đã viết sẵn trong #1 thì thêm cột ngày tháng cũng là thừa

 

[ChanhTQ@]

em thật sự không hiểu cả 2 điều trên

Mình thử lại & thấy bạn đã viết các câu lệnh đúng theo yêu cầu đề bài.

Chúc bạn vui & tham gia tiếp ở những bài sau trong topic này!

 

[Vo Tinh]

Em chưa học Array hay Dic nên chỉ biết làm thế này

[CODE]
Private Sub MyCmd_Click()
With Sheets("Nhap")
   .Range("b10").Resize([b10].End(xlDown).Row - 9, 4).Copy
End With
With Sheets("CTiet")
   .Range("s1").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues: Application.CutCopyMode = False
   .Range("r1").End(xlDown).Offset(1, 0).Resize(.Range("s1").End(xlDown).Row - .Range("r1").End(xlDown).Row, 1) = Sheets("Nhap").Range("c4").Value
   .Range("b2").End(xlDown).Offset(1, 0) = Sheets("Nhap").Range("c3").Value
   .Range("b2").End(xlDown).Offset(0, 1) = Sheets("Nhap").Range("c4").Value
End With 
'MsgBox "Ban Viét Dùm Macro!", , "GPE.COM Xin Nhò"
End Sub
[/CODE]

 

[SA_DQ]

Em chưa học Array hay Dic nên chỉ biết làm thế này

Rất cảm ơn bạn; Rất mong bạn sẽ tiếp tục đóng góp bài vỡ trong topic này

Bạn còn chưa làm 1 nhiệm vụ là xóa dữ liệu cũ; Nếu ta không làm chuyện này thì điều gì dễ sẩy ra, chắc bạn biết.
& 1 khi bạn xóa dữ liệu cũ, thì số dòng nhập mới của 1 fiếu có thể tìm ở bên trang tính 'Nhap' dễ dàng hơn.

Mong bạn tiếp tục bổ sung & sửa đổi macro của mình.

Một lần nữa rất cảm ơn bạn!

 

[Vo Tinh]

Mong bạn tiếp tục bổ sung & sửa đổi macro của mình.

Cám ơn Bác Sa đã hướng dẫn, em sửa lại macro để xóa dữ liệu ở sheet 'Nhap', nhưng cell C3 không thể để trống nên em cho tạm ngày hiện hành vào

[CODE]
Private Sub MyCmd_Click()
If Range("b10") <> "" Then
With Sheets("Nhap")
   .Range("b10").Resize([b10].End(xlDown).Row - 9, 4).Copy
End With
With Sheets("CTiet")
   .Range("s1").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues: Application.CutCopyMode = False
   .Range("r1").End(xlDown).Offset(1, 0).Resize(.Range("s1").End(xlDown).Row - .Range("r1").End(xlDown).Row, 1) = Sheets("Nhap").Range("c4").Value
   .Range("b2").End(xlDown).Offset(1, 0) = Sheets("Nhap").Range("c3").Value
   .Range("b2").End(xlDown).Offset(0, 1) = Sheets("Nhap").Range("c4").Value
End With
With Sheets("Nhap")
   .Range("c3") = Date
   Union(.Range("c4"), .Range("b10").Resize([b10].End(xlDown).Row - 9, 1), .Range("e10").Resize([b10].End(xlDown).Row - 9, 1)).ClearContents
   .Range("c3").Select
End With
End If
End Sub
[/CODE]

 

[ChanhTQ@]

Sao bạn ngại xài biến thế nhỉ?
Những trường hợp như

 [FONT=Courier New][COLOR=#007700].[/COLOR][COLOR=#0000bb]Resize[/COLOR][COLOR=#007700]([[/COLOR][COLOR=#0000bb]b10[/COLOR][COLOR=#007700]].[/COLOR][COLOR=#0000bb]End[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]xlDown[/COLOR][COLOR=#007700]).[/COLOR][COLOR=#0000bb]Row[/COLOR][/FONT]

được lặp lại trong macro của bạn không ít hơn 2 lần.
Vậy nếu ta đưa mệnh đề này thành vô biến thích hợp thì sẽ trong sáng hơn trong macro & fần nào tránh thao tác trên trang tính (mà nhiều người nói rằng sẽ làm chậm hơn quá trình xử lí của macro)

Bạn hỏi VBA xem câu lệnh

.Resize(.Range("s1").End(xlDown).Row - .Range("r1").End(xlDown).Row

có giá trị là bao nhiêu?

 

[SA_DQ]

Bài 2: Lập báo cáo sản lượng nhập hàng từ ngày XXX đấn ngày YYY

Sau khi ta đã nhập được dữ liệu vố CSDL, bước tiếp theo là bắt nó fục vụ chu trình quản lí của ta.
Đó chính là các loại báo cáo cần thiết theo các tiêu chí khác nhau.

Đầu tiên là ta thực hiện báo cáo lượng nhập hàng trong 1 tuần, tháng hay duy chỉ 1 ngày bất kì nào ta muốn.

Chúc các bạn thành công.

 

[Vo Tinh]

Sao bạn ngại xài biến thế nhỉ?

Đúng là có Thầy nó khác, nhìn code nó sáng ra, cám ơn Bác

Private Sub MyCmd_Click()
Dim iR%
iR = Sheets("Nhap").[b65000].End(xlUp).Row - 9
If [b10] <> "" Then
   With Sheets("CTiet")
    .[s1].End(xlDown).Offset(1, 0).Resize(iR, 4).Value = Sheets("Nhap").[b10].Resize(iR, 4).Value
    .[r1].End(xlDown).Offset(1, 0).Resize(iR, 1) = Sheets("Nhap").[c4].Value
    .[b1].End(xlDown).Offset(1, 0) = Sheets("Nhap").[c3].Value
    .[b1].End(xlDown).Offset(0, 1) = Sheets("Nhap").[c4].Value
  End With
  With Sheets("Nhap")
    .[c3] = Date
    Union(.[c4], .[b10].Resize(iR, 1), .[e10].Resize(iR, 1)).ClearContents
    .[c3].Select
  End With
End If
End Sub

Bài 2 chắc phải học Array hoặc Dic gì đó mới làm được

 

[SA_DQ]

Bài 2 chắc phải học Array hoặc Dic gì đó mới làm được

Không hẵn đâu bạn, một khi bạn đọc lại đoạn này thật sâu:
[thongbao]Tác giả file này đã thiết lập qui trình để tạo ra số fiếu này. Chúng được tạo ra theo sự tăng dần của các ngày lập fiếu & trong 1 ngày thì tăng theo thứ tự của 3 kí số cuối.[/thongbao]
Sau đó coi lại trên trang tính xem mã fiếu được mần ra từ đâu.

Sau đó bạn sẽ tự tin hơn & làm được báo cáo với chỉ kiến thức hiện có của bạn.

Chúc sớm thành công!

 

[Vo Tinh]

Sau đó bạn sẽ tự tin hơn & làm được báo cáo với chỉ kiến thức hiện có của bạn.

Chúc sớm thành công!

Em đang làm theo hướng AdvancedFilter nhưng đang bị vướng CriteriaRange
Em làm nó chỉ ra có 1 ngày vì nó không hiểu vùng điều kiện, Bác gợi ý giúp

Sub Report()
Dim iR1%, iR2%
iR1 = Sheets("CTiet").[b65000].End(xlUp).Row - 1
iR2 = Sheets("CTiet").[r65000].End(xlUp).Row - 1
With Sheets("CTiet")
   .[e1:f1].Value = Sheets("CTiet").[q1].Value
   .[e2].Value = ">=" & Sheets("BCao").[c4].Value
   .[f2].Value = "<" & Sheets("BCao").[c5].Value
   .[q2].Resize(iR2, 1).Formula = "=INDEX($B$2:$B$8,MATCH(R2,$C$2:$C$8,0),)"
   .[q1].Resize(iR2, 6).AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("CTiet").[e1:f2], CopyToRange:=Sheets("BCao").[b8]
End With
   'Loc xong se xoa cot Q, vung DK
   'Xoa cot 'Ma so' ben ket qua BCao de phu hop de bai
End Sub

 

[kuldokk]

Em đang làm theo hướng AdvancedFilter nhưng đang bị vướng CriteriaRange
Em làm nó chỉ ra có 1 ngày vì nó không hiểu vùng điều kiện, Bác gợi ý giúp

Sub Report()
Dim iR1%, iR2%
iR1 = Sheets("CTiet").[b65000].End(xlUp).Row - 1
iR2 = Sheets("CTiet").[r65000].End(xlUp).Row - 1
With Sheets("CTiet")
   .[e1:f1].Value = Sheets("CTiet").[q1].Value
   .[e2].Value = ">=" & Sheets("BCao").[c4].Value
   .[f2].Value = "<" & Sheets("BCao").[c5].Value
   .[q2].Resize(iR2, 1).Formula = "=INDEX($B$2:$B$8,MATCH(R2,$C$2:$C$8,0),)"
   .[q1].Resize(iR2, 6).AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("CTiet").[e1:f2], CopyToRange:=Sheets("BCao").[b8]
End With
   'Loc xong se xoa cot Q, vung DK
   'Xoa cot 'Ma so' ben ket qua BCao de phu hop de bai
End Sub

Xin phép được góp ý 1 vài thứ về code của bạn.

1. Cách khai báo biến

Dim iR1%, iR2%

là cách khai báo biến cũ, gọn nhưng khó nhìn, cái này chỉ nói thế thôi, ai muốn thế nào thì dùng vậy. Để cho những người nhìn vào cách khai báo này mà không hiểu thì đây là diễn giải:

& -> Long
% -> Integer
# -> Double
! -> Single
@ -> Decimal
$ -> String

Như vậy

dim iR1%

Sẽ tương đương với

dim iR1 as Integer

2. Kiểu biến

iR1 = Sheets("CTiet").[b65000].End(xlUp).Row - 1
iR2 = Sheets("CTiet").[r65000].End(xlUp).Row - 1

Như đã khai báo kiểu biến iR1 và iR2 là Integer, Integer trong VBA thuộc dạng 16 bits, chỉ lưu được giá trị từ - 32768 đến [FONT=Helvetica Neue, Helvetica, Arial, sans-serif]32767 mà thôi. Nếu làm việc với CSDL, chắc chắn sẽ có khi có số dòng vượt quá con số này.
Để không lỗi: -> khai báo với kiểu dữ liệu là Long trong trường hợp này.

3. Tên biến.

iR1 , iR2 chắc là viết tắt của "index of row 1", "index of row 2" , liệu nhìn vào đây có biết 2 biến này nghĩa là gì không. -> đặt tên cần mang tính miêu tả hơn. Có thể trong trường hợp này không cần thiết vì code ít, ... tuỳ.

4. Cách tìm dòng cuối.

[/FONT]

iR1 = Sheets("CTiet").[b65000].End(xlUp).Row - 1
iR2 = Sheets("CTiet").[r65000].End(xlUp).Row - 1

Nếu dữ liệu nhiều hơn 65000 dòng thì:
1. code trên có tìm được dòng cuối không?
2. Nếu thay 65000 bằng 1000000 (gần mức giới hạn của Excel từ bản 2007 trở lên), code trên có đảm bảo tìm được dòng cuối trong mọi trường hợp không?

 

[SA_DQ]

Bạn thử cách này với fương thức AdvancedFilte gồm các bước sau:

Giai đoạn thử nghiệm (A):

A1: Tại trang 'BCao', tại [C4] ta nhập giá trị đang có tại [G4] & cũng vậy với [C5] tương ứng. (Có nghĩa là sẽ báo cáo suốt từ đầu đến cuối chu trình)
A2: Tại [AA1] ta nhập công thức =c7; Ta sẽ lấy ô này & ô bên dưới nó làm điều kiện lọc.
A3: Ta sang trang 'CTiet' & chọn 1 lấy bất kỳ chuỗi nào mà bạn thích thuộc cột dữ liệu [C:C] & copy nó đến [AA2] của trang tính 'BCao'
A4: Mở bộ thu macro lên & thu lại quá trình tiến hành lọc AddvancedFilter (với trang tính 'BCao' nha)
Từ trang này, bạn vô menu 'Data' (E2003)-> Filter -> Advanced Filter
Bấm chọn dòng Copy to another location
Nhấn chuột vô của sổ (CS) "List range". Lúc này ta sang trang 'CTiet' & chọn toàn vùng dữ liệu của khối chi tiết;
(Sau khi quay về trang 'BCao'), ta nhấn chuột vô CS 'Criteria range' & nhấn chuột chọn vùng [AA1:AA2]

Xuống CS cuối & lấy chuột làm sao đó để CS này hiện địa chỉ [C7:G7]

Ta nhấn nút 'OK' để fương thức cho ta kết quả.
Tắt bộ thu macro

Tiến hành chiêm nghiệm các kết quả đạt được trên trang tính & trong CS VBE.

Giai đoạn thực hành viết macro:

1. Tạo vòng lặp duyệt toàn bộ số liệu ngày tại cột của trang 'CTiet'
2. Nếu ngày nào đó đang duyệt thỏa điều kiện trong giới hạn của [C4:C5] (của trang 'BCao') thì gởi dữ liệu bên fải liền kề với ô đang duyệt đến [AA2]
3. Iêu cầu macro đã thu tiến hành làm công việc của mình

Nếu chẳng may trong khoảng ngày cần khảo sát chỉ có 1 fiếu nhập thì ta đúng; Nhưng hiếm lắm. Còn nhiều fiếu thỏa điều kiện thì macro sẽ chép đè lên nhau & bạn chỉ thấy kết quả của kì lọc cuối mà thôi

Công việc làm sao để không chép đè, mà chép nối là công việc của bạn!

 

[Vo Tinh]

Nếu chẳng may trong khoảng ngày cần khảo sát chỉ có 1 fiếu nhập thì ta đúng; Nhưng hiếm lắm. Còn nhiều fiếu thỏa điều kiện thì macro sẽ chép đè lên nhau & bạn chỉ thấy kết quả của kì lọc cuối mà thôi

Công việc làm sao để không chép đè, mà chép nối là công việc của bạn!

Cám ơn Anh kuldokka và Bác SA, em làm ra đúng còn cái màu đỏ thì tìm hoài chưa ra cách
Em chuyển sang dùng vòng lập vậy

Sub report()
Dim lastRow As Long, i As Long, myRg As Range, k As Long
lastRow = Sheets("CTiet").Range("q" & Rows.Count).End(xlUp).Row
Set myRg = Sheets("CTiet").Range("q2:v" & lastRow)
Sheets("BCao").range("b8:g1000").ClearContents
For i = 1 To lastRow
    If myRg.Cells(i, 1) >= Sheets("BCao").[c4] And myRg.Cells(i, 1) <= Sheets("BCao").[c5] Then
    k = k + 1
    With Sheets("BCao")
    .[b7].Offset(k, 0) = myRg.Cells(i, 1)
    .[c7].Offset(k, 0) = myRg.Cells(i, 2)
    .[d7].Offset(k, 0) = myRg.Cells(i, 4)
    .[e7].Offset(k, 0) = myRg.Cells(i, 5)
    .[f7].Offset(k, 0) = myRg.Cells(i, 6)
    .[g7].Offset(k, 0) = myRg.Cells(i, 7)
    End With
    End If
Next i
End Sub

 

[doveandrose]

giả sử như mã phiếu không chứa thông điệp ngày trong nó thì chắc phải filter 2 lần

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngRS As Range, lr As Long, vungDK As Range, lrDT As Long, r As Long


If Target.Address = "$C$4" Then Target.Offset(1).Value = Target.Value2
If Target.Address = "$C$5" Then
    Application.ScreenUpdating = False
    With Worksheets("BCao")
        .[A7].Value = .[B7].Value
        .[A8].Value = ">=" & .[C4].Value2
        .[B8].Value = "<=" & .[C5].Value2
        Set vungDK = .Range("A7:B8")
    End With
    With Worksheets("CTiet")
        lr = WorksheetFunction.Max(.[B65000].End(xlUp).Row, 2)
        lrDT = WorksheetFunction.Max(.[R65000].End(xlUp).Row, 2)
        .Range("B1:C" & lr).AdvancedFilter CriteriaRange:=vungDK, Action:=xlFilterInPlace
        Worksheets("BCao").Range("A8:F" & (lrDT + 100)).ClearContents
        If .Range("C1:C" & lr).SpecialCells(xlCellTypeVisible).Address = "$C$1" Then GoTo nors
        .Range("C2:C" & lr).SpecialCells(xlCellTypeVisible).Copy
        Worksheets("BCao").Range("C8").PasteSpecial xlPasteValues
        Set vungDK = Worksheets("BCao").Range("C7:C" & Worksheets("BCao").Range("C7").End(xlDown).Row)
        .Range("R1:V" & lrDT).AdvancedFilter CriteriaRange:=vungDK, Action:=xlFilterInPlace
        Worksheets("BCao").Range("C8:C" & (lr + 100)).ClearContents
        If .Range("R1:R" & lrDT).SpecialCells(xlCellTypeVisible).Address = "$R$1" Then GoTo nors
        .Range("R2:V" & lrDT).SpecialCells(xlCellTypeVisible).Copy
    End With
    
    With Worksheets("BCao")
        .Range("B8").PasteSpecial xlPasteValues
        lrDT = .Range("B7").End(xlDown).Row
        .Range("C8:C" & lrDT).Value = .Range("B8:B" & lrDT).Value
        .Range("B8:B" & lrDT).Formula = _
        "=OFFSET(CTiet!$B$1,MATCH(C8,CTiet!$C$2:$C$" & lr & ",0),0)"
        .Range("A8:A" & lrDT).Formula = "=row(A8)-7"
    End With
nors:
    Worksheets("BCao").Range("A7").Value = "TT"
    Worksheets("CTiet").Range("B1").AutoFilter
    Application.ScreenUpdating = True
End If
End Sub

bài làm trông xấu quá . hihi . mình rất biết ơn nếu được hướng dẫn để tìm được cách làm tốt hơn

 

[SA_DQ]

Đây là 1 cách làm theo đường hướng AdvancedFilter;
Nhưng cột [Ngày] trong form báo cáo chưa có số liệu

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [c5]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, Cls As Range
    Dim fDat As Date, lDat As Date
    
    Set Sh = ThisWorkbook.Worksheets("CTiet")
    lDat = Target.Value:        fDat = Target.Offset(-1).Value
    [AA2].CurrentRegion.Offset(1).ClearContents
    [B8].CurrentRegion.Offset(1, 1).ClearContents
    For Each Cls In Sh.Range(Sh.[b2], Sh.[b2].End(xlDown))
        With Cls
            If .Value >= fDat And .Value <= lDat Then
                [aa9999].End(xlUp).Offset(1).Value = Cls.Offset(, 1).Value
            End If
        End With
    Next Cls
    Set Rng = [AA2].CurrentRegion
    Sh.Columns("R:W").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Rng, CopyToRange:=Range("C7:G7"), Unique:=False
 End If
End Sub