Các bài tập VBA đơn giản dùng để xử lí CSDL (cơ sở dữ liệu) [Fần 3] (1 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

 

[ChanhTQ@]

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

Nhưng thực tế nó đang chứa thông điệp về ngày-tháng-năm nhập hàng mà.
Rất mong bạn thực hiện í tưởng theo thông điệp này để cộng đồng chiêm ngưỡng.
Rất cảm ơn bạn trước!

 

[Vo Tinh]

Nhưng thực tế nó đang chứa thông điệp về ngày-tháng-năm nhập hàng mà.
Rất mong bạn thực hiện í tưởng theo thông điệp này để cộng đồng chiêm ngưỡng.
Rất cảm ơn bạn trước!

Từ bài của Bác SA đã học được thêm CurrentRegion
Nhận ra điều kiện lọc OR đơn giản, đằng này em cứ tìm điều kiện AND với mấy cái <,>,= nên chẳng ra được
Em làm Function TraMa() để trả từ Mã về Ngày và điền Ngày và STT vào BCao

Sub report()
Dim lastRow As Long, lastRow2 As Long, lastRow3 As Long, i As Long, myRg As Range, k As Long, j As Long
lastRow = Sheets("CTiet").Range("B" & Rows.Count).End(xlUp).Row
lastRow2 = Sheets("CTiet").Range("R" & Rows.Count).End(xlUp).Row
Set myRg = Sheets("CTiet").Range("B2:C" & lastRow)
Union(Sheets("BCao").[AA1].CurrentRegion.Offset(1, 0), Sheets("BCao").[B8].CurrentRegion.Offset(1, 0)).ClearContents
    For i = 1 To lastRow - 1
        If myRg.Cells(i, 1) >= Sheets("BCao").[C4] And myRg.Cells(i, 1) <= Sheets("BCao").[C5] Then
            k = k + 1
            Sheets("BCao").[AA1].Offset(k, 0) = myRg.Cells(i, 2)
        End If
    Next i
Sheets("CTiet").Range("R1:W" & lastRow2).AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("BCao").[AA1].CurrentRegion, CopyToRange:=Sheets("BCao").[C7:G7]
lastRow3 = Sheets("Bcao").Range("C" & Rows.Count).End(xlUp).Row
    For j = 1 To lastRow3 - 7
        Sheets("BCao").Range("A" & j + 7) = j
        Sheets("BCao").Range("B" & j + 7).FormulaR1C1 = "=trama(RC[1])"
    Next j
End Sub

Function TraMa(Optional Ma As String) As Date
Dim yR As Integer, Mth As Integer, Dy As Integer
Const StrC$ = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
yR = Application.WorksheetFunction.Find(Mid(Ma, 1, 1), StrC$, 1) + 2000
Mth = Application.WorksheetFunction.Find(Mid(Ma, 2, 1), StrC$, 1) - 1
Dy = Application.WorksheetFunction.Find(Mid(Ma, 3, 1), StrC$, 1) - 1
TraMa = Format(DateSerial(yR, Mth, Dy), "dd/MM/yyyy")
End Function

 

[doveandrose]

Nhưng thực tế nó đang chứa thông điệp về ngày-tháng-năm nhập hàng mà.
Rất mong bạn thực hiện í tưởng theo thông điệp này để cộng đồng chiêm ngưỡng.
Rất cảm ơn bạn trước!

làm vậy e không đúng với ý đồ của tác giả SA_DQ thôi chứ dùng filter chỉ 1 lần còn lẹ hơ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
Dim wsBC As Worksheet, wsCT As Worksheet


If Target.Address = "$C$4" Then Target.Offset(1).Value = Target.Value2
If Target.Address = "$C$5" Then
    Application.ScreenUpdating = False
    Set wsBC = Worksheets("BCao")
    Set wsCT = Worksheets("CTiet")


    With wsBC
        .[K1].Value = .[C7].Value
        .[L1].Value = .[C7].Value
        .[K2].Value = ">=" & TaoMa(.[C4].Value) & "N001"
        .[L2].Value = "<=" & TaoMa(.[C5].Value) & "N999"
        Set vungDK = .Range("K1:L2")
    End With
    With wsCT
        lr = WorksheetFunction.Max(.[B65000].End(xlUp).Row, 2)
        lrDT = WorksheetFunction.Max(.[R65000].End(xlUp).Row, 2)
        Worksheets("BCao").Range("A8:F" & (lrDT + 100)).ClearContents
        .Range("R1:W" & lrDT).AdvancedFilter CriteriaRange:=vungDK, Action:=xlFilterCopy, _
        CopyToRange:=wsBC.Range("C7:G7")
    End With
    
    With wsBC
        If .[C8].Value <> "" Then
            lrDT = .[C7].End(xlDown).Row
            .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 If
        .Range("K1:L2").ClearContents
    End With
    Application.ScreenUpdating = True
End If
End Sub

 

[SA_DQ]

Em làm Function TraMa() để trả từ Mã về Ngày và điền Ngày và STT vào BCao

Rất sáng tạo trong suy nghĩ!

(.) Trong VBA có hàm =InStr("ABC","B") => 2
(.) Câu lệnh này có thể cải biến để đỡ nặng máy:

Sheets("BCao").Range("B" & j + 7).FormulaR1C1 = "=trama(RC[1])"

Bằng cách iêu cầu hàm trả kết quả dưới dạng Value cho ô í luôn.

Rất mong bạn tiếp tục hưởng ứng topic này.

 

[Vo Tinh]

(.) Trong VBA có hàm =InStr("ABC","B") => 2
(.) Câu lệnh này có thể cải biến để đỡ nặng máy:

Sheets("BCao").Range("B" & j + 7).FormulaR1C1 = "=trama(RC[1])"

Bằng cách iêu cầu hàm trả kết quả dưới dạng Value cho ô í luôn.

Cám ơn Bác về hàm InStr(), thế mà em đi tìm hàm Find() trong VBA mà không có.
Để trả về Value thì em chỉ biết thêm 1 dòng lệnh này vào thôi

Sheets("BCao").Range("B" & j + 7).FormulaR1C1 = "=trama(RC[1])"
Sheets("BCao").Range("B" & j + 7) = Sheets("BCao").Range("B" & j + 7).Value

 

[Vo Tinh]

Bằng cách iêu cầu hàm trả kết quả dưới dạng Value cho ô í luôn.

Ah thì ra đặt hàm trong VBE thì trên sheet ra Value luôn

Sheets("BCao").Range("B" & j + 7) = TraMa(Sheets("BCao").Range("C" & j + 7))

Trong bài Anh doveandrose có điều kiện lọc là Mã, nhưng em không hiểu là Mã mà có thể so sánh lớn hơn, nhỏ hơn được ?

.[K2].Value = ">=" & TaoMa(.[C4].Value) & "N001"
.[L2].Value = "<=" & TaoMa(.[C5].Value) & "N999"

 

[SA_DQ]

Thực ra chúng ta đã xem xét 1 CSDL chưa thực lắm.

CSDL mà mấy lâu nay ta xem xét chỉ mới có khâu nhập, chưa có khâu xuất.
Nhưng vì loạt bài mới, sợ 1 số người thấy "to tác" quá, ít quan tậm nên mới vậy.
Dưới đây là 1 CSDL mới được chỉnh lại để chúng ta thực hành bài tập thứ 3:

Bài tập 3: Hãy lọc sản lượng nhập riêng 1 cột & xuất riêng 1 cột theo các ngày đã chỉ định. (Như trong trang tính 'BCao')

 

[doveandrose]

thầy ơi bài này code trong file luôn rồi . chắc có nhầm lẫn gì chăng ?

 

[SA_DQ]

thầy ơi bài này code trong file luôn rồi . chắc có nhầm lẫn gì chăng ?

Học viên này tấy mấy quá đó nha!

Cứ coi như đó là đáp án tồi đi vậy!

Rất mong các bạn tham gia giải theo các kiểu khác nữa như các bài trên nó; để cộng đồng có thêm nhiều tham khảo.

Rất cảm ơn bạn & mọi người!

 

[Vo Tinh]

Rất mong các bạn tham gia giải theo các kiểu khác nữa như các bài trên nó; để cộng đồng có thêm nhiều tham khảo.

Em đã chuyển sang CSDL mới
Em thêm 1 dòng lệnh vào macro cũ để có SL nhập

Sub report()
Dim lastRow As Long, lastRow2 As Long, lastRow3 As Long, sH As Worksheet, i As Long, myRg As Range, k As Long, j As Long
Set sH = ThisWorkbook.Worksheets("CTiet")
lastRow = sH.Range("B" & Rows.Count).End(xlUp).Row
lastRow2 = sH.Range("R" & Rows.Count).End(xlUp).Row
Set myRg = sH.Range("B2:C" & lastRow)
Union(Sheets("BCao").[AA1].CurrentRegion.Offset(1, 0), Sheets("BCao").[B9].CurrentRegion.Offset(2, 0)).ClearContents
    For i = 1 To lastRow - 1
        If myRg.Cells(i, 1) >= Sheets("BCao").[C4] And myRg.Cells(i, 1) <= Sheets("BCao").[C5] Then
            k = k + 1
            Sheets("BCao").[AA1].Offset(k, 0) = myRg.Cells(i, 2)
        End If
    Next i
Sheets("CTiet").Range("R1:W" & lastRow2).AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("BCao").[AA1].CurrentRegion, CopyToRange:=Sheets("BCao").[C8:F8], Unique:=False
With Sheets("Bcao")
lastRow3 = .Range("C" & Rows.Count).End(xlUp).Row
    For j = 1 To lastRow3 - 8
        .Range("A" & j + 8) = j
        .Range("B" & j + 8) = TraMa(.Range("C" & j + 8))
        If Mid(.Range("C" & j + 8), 4, 1) = "X" Then .Range("F" & j + 8).Cut .Range("G" & j + 8)
    Next j
End With
End Sub

 

[ChanhTQ@]

Em thêm 1 dòng lệnh vào macro cũ để có SL nhập

Sub report()
Dim lastRow As Long, lastRow2 As Long, lastRow3 As Long, sH As Worksheet, i As Long, myRg As Range, k As Long, j As Long
Set sH = ThisWorkbook.Worksheets("CTiet")
lastRow = sH.Range("B" & Rows.Count).End(xlUp).Row
lastRow2 = sH.Range("R" & Rows.Count).End(xlUp).Row
Set myRg = sH.Range("B2:C" & lastRow)
Union(Sheets("BCao").[AA1].CurrentRegion.Offset(1, 0), Sheets("BCao").[B9].CurrentRegion.Offset(2, 0)).ClearContents
    For i = 1 To lastRow - 1
        If myRg.Cells(i, 1) >= Sheets("BCao").[C4] And myRg.Cells(i, 1) <= Sheets("BCao").[C5] Then
            k = k + 1
            Sheets("BCao").[AA1].Offset(k, 0) = myRg.Cells(i, 2)
        End If
    Next i
Sheets("CTiet").Range("R1:W" & lastRow2).AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("BCao").[AA1].CurrentRegion, CopyToRange:=Sheets("BCao").[C8:F8], Unique:=False
With Sheets("Bcao")
lastRow3 = .Range("C" & Rows.Count).End(xlUp).Row
    For j = 1 To lastRow3 - 8
        .Range("A" & j + 8) = j
        .Range("B" & j + 8) = TraMa(.Range("C" & j + 8))
        If Mid(.Range("C" & j + 8), 4, 1) = "X" Then .Range("F" & j + 8).Cut .Range("G" & j + 8)
    Next j
End With
End Sub

Bạn đã gán bỡi lệnh: Set sH = ThisWorkbook.Worksheets("CTiet")
Thì câu lệnh

Sheets("CTiet").Range("R1:W" & lastRow2).AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("BCao").[AA1].CurrentRegion, CopyToRange:=Sheets("BCao").[C8:F8], Unique:=False

lí ra fải là khác đi 1 chút, còn như viết vậy bạn đang lãng fí chút nào đó 'tài nguyên' của bạn!

Thứ nhì: Nhìn vô macro của bạn có quá nhiều cụm từ "Sheets("BCao")."
Bạn hãy tìm cách chỉ xài cụm từ này 1 lần trong macro của mình thôi, cố gắng nha!

(húc thành công!

 

[SA_DQ]

Bài tập 4: Xây dựng thẻ kho mặt hàng

Theo mẫu có trong hình vẽ kèm theo

(húc nhiều thành công!

 

[ChanhTQ@]

Mình xin giới thiệu đến bạn Vo Tinh & vài các bạn khác một cách thức xài mảng đơn giản nhất có thể.
Để vậy ta tạm chia macro ở bài #30 ra làm ba công đoạn

CĐ1: Tạo dữ liệu cho vùng ‘Criteria’ để lọc
CĐ2: Chỉ là 1 dòng lệnh áp dụng fương thức AdvancedFilter
CĐ3: Điền dữ liệu ngày tháng tạo fiếu & số liệu xuất trong các fiếu & xóa số liệu xuất vừa lọc được

Sau CĐ2 ta có số liệu gần giống như trong hình ở bài #28 của Doveandrose
Khác ở chổ chưa có số liệu ngày ở vùng [B9:B22] & [G9:G22]
Chúng ta sẽ thực hiện đoạn macro xài mảng cho CĐ3 này:

 With Sheets("Bcao")
lastRow3 = .Range("C" & Rows.Count).End(xlUp).Row
    For j = 1 To lastRow3 - 8
        .Range("A" & j + 8) = j
        .Range("B" & j + 8) = TraMa(.Range("C" & j + 8))
        If Mid(.Range("C" & j + 8), 4, 1) = "X" Then .Range("F" & j + 8).Cut .Range("G" & j + 8)
    Next j
End With

Để việc chuyển biến này không choáng ngợp, ta tạm thời viết 1 macro khác; Sau khi viết xong ta vô hiệu hóa CĐ3 & thêm dòng lệnh triệu gọi macro vừa viết là được.

Macro mới có tên là Temp với nội dung như sau:

Sub Temp()
 Dim Rw%, J%, StrC$, Arr()
 
2 Rw = [c7].CurrentRegion.Rows.Count
 ReDim Arr(1 To Rw, 1 To 6)
 
4 Arr = [B9].Resize(Rw, 6).Value
 For J = 1 To UBound(Arr())
6    StrC = Arr(J, 2)
    Arr(J, 1) = GiaiMa(StrC)
8    If InStr(Arr(J, 2), "X") Then
        Arr(J, 6) = Arr(J, 5)
10        Arr(J, 5) = ""
    End If
12 Next J
 [B9].Resize(Rw, 6).Value = Arr()
End Sub

D1: Khai báo 4 biến để xài, trong đó 2 biến đầu ta đã quen; Biến StrC kiểu chuỗi & 1 mảng Arr()
D2: Lấy chỉ số dòng của vùng liên tục xung quanh [C7] đưa vô 1 biến số đã khai báo;
D3: Khai báo 1 biến mảng có số dòng bằng với số dòng dữ liệu vừa tìm, số cột là 6
D4: Ta đưa toàn bộ dữ liệu vùng mà CĐ2 vừa lọc được vô biến mảng.
Có điều cần chú í là cột ngày-tháng & cột ‘Xuất’ đang trống dữ liệu ta cũng đưa chúng vô mảng; 1 chàng thì đầu sông, 1 nàng thì cuối sông ( cột của mảng).

D5: Thiết lập vòng lặp từ 1 cho đến dòng cuối của chỉ số dòng của mảng Arr(); Thực ra ta có thể viết từ 1 cho đến Rw – là số dòng có dữ liệu của vùng. Vòng lặp này khi xong sẽ điền số liệu ngày vô cột ‘đầu sông’ & cột ‘cuối sông’ (xuất). Hơn nữa, chỉ điền cho ‘cuối sông’ khi trong chuỗi số fiếu có kí tự ‘X’
D6: Lấy giá trị thuộc cột thứ 2 của dòng đang khảo sát đưa vô biến chuỗi
D7: Điền ngày-tháng cho cột ‘đầu sông’
D8: Thiết lập điều kiện tìm số fiếu xuất; Điều kiện này kết thúc ở dòng D11
D9: Điền vô cột ‘cuối sông’ của mảng khi thỏa ĐK
D10: Xóa trị đã điền sang ‘cuối sông’ ở cột trái liện kề trong mảng.
D12: Kết thúc vòng lặp
D13: Ghi những gì trong mảng lên trang tính

Mong ít nhiều giúp bạn có khái niệm ban đầu hết sức nhỏ nhoi về xài mảng.

 

[doveandrose]

Theo mẫu có trong hình vẽ kèm theo

(húc nhiều thành công!

em xin chịu thua vì không biết lấy cái gì lắp vào ô F4 trong hình vẽ

 

[SA_DQ]

em xin chịu thua vì không biết lấy cái gì lắp vào ô F4 trong hình vẽ

Tồn đầu năm hiện trong file là bằng không. Còn muốn có cái số gì đó thì ta đến trang 'DMuc' & thêm vô [E1] tiêu đề là tồn đầu năm & giả lập số liệu kiểm kê cuối năm trước vô thôi.

Sau đó cũng như vài 3 ô khác trong hình ta VLOOKUP() mà thôi.

Chúc vui!

 

[Vo Tinh]

Tồn đầu năm hiện trong file là bằng không. Còn muốn có cái số gì đó thì ta đến trang 'DMuc' & thêm vô [E1] tiêu đề là tồn đầu năm & giả lập số liệu kiểm kê cuối năm trước vô thôi.
Sau đó cũng như vài 3 ô khác trong hình ta VLOOKUP() mà thôi.
Chúc vui!

Các cell phần trên của Thẻ Kho em dùng công thức Vlookup() lấy dữ liệu từ DMuc, thêm cột số liệu tồn kiểm kê vào DMuc.
Trong macro sẽ không làm các việc trên.
Cám ơn hướng dẫn các bước cơ bản Array của Bác, em đã tìm và học trên diễn đàn và cuối cùng cũng áp dụng vào macro của mình, có gì Bác và các AC hướng dẫn góp ý thêm

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [F3]) Is Nothing Then
    Dim lastRow As Long, i As Long, k As Long, myStr As String, sArr, rArr
    lastRow = Sheets("CTiet").[R1].CurrentRegion.Rows.Count
    ReDim sArr(1 To lastRow, 1 To 6)
    sArr = Sheets("CTiet").Range("R2:W" & lastRow)
    ReDim rArr(1 To UBound(sArr), 1 To 6)
        For i = 1 To lastRow - 1
            If sArr(i, 2) = [F3].Value Then
                k = k + 1
                myStr = sArr(i, 1) : rArr(k, 1) = k : rArr(k, 2) = TraMa(myStr) : rArr(k, 6) = sArr(i, 1)
                    If Mid(sArr(i, 1), 4, 1) = "N" Then
                        rArr(k, 3) = sArr(i, 5)
                    Else
                        rArr(k, 4) = sArr(i, 5)
                    End If
                        If k = 1 Then
                        rArr(k, 5) = [F4].Value + rArr(k, 3) - rArr(k, 4)
                        Else
                        rArr(k, 5) = rArr(k - 1, 5) + rArr(k, 3) - rArr(k, 4)
                        End If
            End If
        Next i
    [B7].CurrentRegion.Offset(1, 0).ClearContents
    [B7].Resize(lastRow, 6).Value = rArr
End If
End Sub

 

[SA_DQ]

1   [B7].CurrentRegion.Offset(1, 0).ClearContents
2    [B7].Resize(lastRow, 6).Value = rArr

Câu lệnh (1) nên để trước vòng lặp For . . . Next
Còn vì sao bạn thử tìm hiểu xem, 1 khi vòng lặp gặp gì đó bất thường.

(2) Nhiều nơi bên dưới biểu mẫu thẻ kho còn có 1 số dữ liệu bắt buộc fải có
Như

Mẫu số: S09-DNN
(Ban hành theo QĐ số: 48/2006/QĐ-BTC
ngày 14/9/2006 của Bộ trưởng BTC)

,. . . .
Vậy nên bạn nên mở volume (lastRow) vừa đủ nghe để khỏi ảnh hưởng đến hàng xóm!

 

[SA_DQ]

Bài tập 5: Báo cáo số liệu nhập xuất tồn trong kì.

Chúng ta cần tạo trang tính mới có nội dung như trong hình;
5 tiêu đề đầu của dòng 7 & số liệu dưới nó được chép từ 'DMuc' qua;
Nhiệm vụ bài này là điều đầy số liệu hoạt động của 'CTiet'
[Tồn ĐK]: Lượng nhập xuất từ đầu năm cho đến ngày đầu
[Nhập] & [Xuất] là lương nhập & xuất tương ứng trong kì đã định
[Tồn]: Ta có thể lắp bỡi công thức của Excel (hay tính trực tiếp trên VBA)

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

 

[Vo Tinh]

Chúng ta cần tạo trang tính mới có nội dung như trong hình;
5 tiêu đề đầu của dòng 7 & số liệu dưới nó được chép từ 'DMuc' qua;
Nhiệm vụ bài này là điều đầy số liệu hoạt động của 'CTiet'
[Tồn ĐK]: Lượng nhập xuất từ đầu năm cho đến ngày đầu
[Nhập] & [Xuất] là lương nhập & xuất tương ứng trong kì đã định
[Tồn]: Ta có thể lắp bỡi công thức của Excel (hay tính trực tiếp trên VBA)

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

Lòng vòng với mảng

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C5]) Is Nothing Then
    Dim sh As Worksheet, lastRowCT As Long, lastRowDM As Integer, i As Long, j As Long, myStr As String, sArr, sArr2, rArr
    Dim startDay As Date, finishDay As Date, n As Single, x As Single, nt As Single, xt As Single
    Set sh = ThisWorkbook.Worksheets("CTiet")
    startDay = [C4].Value:    finishDay = [C5].Value
    lastRowCT = sh.[R1].CurrentRegion.Rows.Count
    lastRowDM = Sheets("DMuc").[A1].CurrentRegion.Rows.Count
    ReDim sArr(1 To lastRowCT, 1 To 6):    sArr = sh.Range("R2:W" & lastRowCT)
    ReDim sArr2(1 To lastRowDM - 1, 1 To 5):    sArr2 = Sheets("Dmuc").Range("A2:E" & lastRowDM)
    ReDim rArr(1 To lastRowDM - 1, 1 To 10)
    [A8].CurrentRegion.Offset(1, 0).ClearContents
    For i = 1 To lastRowDM - 1
        n = 0: nt = 0
        x = 0: xt = 0
        rArr(i, 1) = i
        rArr(i, 2) = sArr2(i, 2):        rArr(i, 3) = sArr2(i, 3)
        rArr(i, 4) = sArr2(i, 4):        rArr(i, 5) = sArr2(i, 5)
        For j = 1 To lastRowCT - 1
            myStr = sArr(j, 1)
            sArr(j, 6) = TraMa(myStr)
                If sArr(j, 6) >= startDay And sArr(j, 6) <= finishDay And sArr(j, 2) = sArr2(i, 2) Then
                    If Mid(sArr(j, 1), 4, 1) = "N" Then
                        n = n + sArr(j, 5)
                    ElseIf Mid(sArr(j, 1), 4, 1) = "X" Then
                        x = x + sArr(j, 5)
                    End If
                ElseIf sArr(j, 6) < startDay Or sArr(j, 6) > finishDay And sArr(j, 2) = sArr2(i, 2) Then
                    If Mid(sArr(j, 1), 4, 1) = "N" Then
                        nt = nt + sArr(j, 5)
                    ElseIf Mid(sArr(j, 1), 4, 1) = "X" Then
                        xt = xt + sArr(j, 5)
                    End If
                End If
        Next j
        rArr(i, 7) = n: rArr(i, 8) = x: rArr(i, 6) = rArr(i, 5) + nt - xt: rArr(i, 9) = rArr(i, 6) + n - x
    Next i
    [A8].Resize(lastRowDM - 1, 10).Value = rArr
End If
End Sub

Function TraMa(Optional Ma As String) As Date
Dim yR As Integer, Mth As Integer, Dy As Integer
Const StrC$ = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
yR = InStr(StrC, Mid(Ma, 1, 1)) + 2000
Mth = InStr(StrC, Mid(Ma, 2, 1)) - 1
Dy = InStr(StrC, Mid(Ma, 3, 1)) - 1
TraMa = Format(DateSerial(yR, Mth, Dy), "dd/MM/yyyy")
End Function

Vậy nên bạn nên mở volume (lastRow) vừa đủ nghe để khỏi ảnh hưởng đến hàng xóm!

Em đã chỉnh "volume" vừa đủ nghe ở bài trước. Thanks Bác SA

 

[SA_DQ]

Bạn nên tách ra làm 2 sự kiện.

Trong macro của bạn mình cho là có 2 sự kiện đan xen nhau.
Như mình thì mình sẽ tách ra làm 2:

1 sự kiện diễn ra khi kích hoạt trang tính

Private Sub Worksheet_Activate()
End Sub

Trong sự kiện này ta viết toàn bộ quá trình chép dữ liệu từ 'DMuc' sang 5 cột được tô vàng màu nền ở bài #39
Lí do ư: Trang danh mục này ít khi thay đổi nội dung; Nó tăng giảm loại mặt hàng không thể 1 sớm 1 chiều.
Nó thay đổi khi có biến động cônghệ, biến động lớn về nhà cung cấp ,. . .
Những biến động này rất lâu mới diễn ra một khi CQ đã đi vào hoạt động ổn định.
Nhưng macro của bạn thì lần chạy nào bạn cũng bắt nó làm đi làm lại những động tác tạm gọi là vô bổ đó! (đừng giận nha!)
Nêu chăng ta tách fần chép số liệu này ra riêng 1 macro

Như trên gợi í, chí ít bạn nên đưa vô thủ tục 'mở trang tính'

Macro còn lại chỉ là những việc:

(*) Tạo vòng lặp duyệt theo cột mã số mặt hàng (cột ) của trang 'NXT'

(*) Tiếp theo dò tìm trong vùng chi tiết của trang 'CTiet' xem dòng nào mà có mã hàng trùng với mã ta đang duyệt thì sử lí nó theo các hướng sau:
(+) Nếu có ngày bé hơn 'ngày đầu' ghi nối vô cột [G:G]
(Tất nhiên có công đoạn xét xem dòng đó là 'Nhập' hay 'Xuất'
Nếu 'Xuất' thì trừ đi, nếu 'Nhập' với số hiện có trong cột [G] cùng dòng mã hàng ta đang khảo sát.
Ta chép vô cột [G:G] chứ không chép vô cột [F]; Cột [F:f] ta lập công thức cộng 2 trị tồn đầu năm & tồn đầu kì lại với nhau.
Tất nhiên ta cho ẩn cột [G:G] đi khi báo cáo đã hoàn thiện.
(+) Còn ngày trong kỳ khảo sát (kì báo cáo) thì ta cộng thêm vô cột 'Nhập' hay 'Xuất' tương ứng theo kí tự thứ 4 trong mã fiếu.
Còn cột 'Tồn' ta sẽ lập 1 fép cộng đại số thôi.


Chia để trị dễ bảo trì hơn nhiều đó bạn!

Rất mong bạn thực hiện chu trình gợi í này. Lúc đó macro của bạn sẽ sáng sửa hơn là cái chắc.
Chúc bạn thành công mĩ mãn!

 

[Vo Tinh]

Chia để trị dễ bảo trì hơn nhiều đó bạn!

Em đã chỉnh sửa theo hướng dẫn của Bác, cám ơn Bác đã tận tình

Private Sub Worksheet_Activate()
Dim sh As Worksheet
Set sh = Sheets("DMuc")
    [A8].CurrentRegion.Offset(1, 0).ClearContents
    sh.[A1].CurrentRegion.Copy [A7]
    Application.CutCopyMode = False
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C5]) Is Nothing Then
    Dim sh As Worksheet, lastRowCT As Long, lastRowDM As Integer, i As Long, j As Long, myStr As String, sArr, sArr2, rArr
    Dim startDay As Date, finishDay As Date, n As Single, x As Single, nt As Single, xt As Single
    Set sh = ThisWorkbook.Worksheets("CTiet")
    startDay = [C4].Value:                     finishDay = [C5].Value
    lastRowCT = sh.[R1].CurrentRegion.Rows.Count
    lastRowDM = Sheets("DMuc").[A1].CurrentRegion.Rows.Count
    ReDim sArr(1 To lastRowCT, 1 To 6):        sArr = sh.Range("R2:W" & lastRowCT)
    ReDim sArr2(1 To lastRowDM - 1, 1 To 4):   sArr2 = Sheets("Dmuc").Range("B2:F" & lastRowDM)
    ReDim rArr(1 To lastRowDM - 1, 1 To 5)
    For i = 1 To lastRowDM - 1
        n = 0: nt = 0
        x = 0: xt = 0
            For j = 1 To lastRowCT - 1
                If sArr(j, 2) = sArr2(i, 1) Then
                    myStr = sArr(j, 1)
                    If TraMa(myStr) < startDay Then
                        If Mid(sArr(j, 1), 4, 1) = "N" Then
                            nt = nt + sArr(j, 5)
                        ElseIf Mid(sArr(j, 1), 4, 1) = "X" Then
                            xt = xt + sArr(j, 5)
                        End If
                    ElseIf TraMa(myStr) >= startDay And TraMa(myStr) <= finishDay Then
                        If Mid(sArr(j, 1), 4, 1) = "N" Then
                            n = n + sArr(j, 5)
                        ElseIf Mid(sArr(j, 1), 4, 1) = "X" Then
                            x = x + sArr(j, 5)
                        End If
                    End If
                End If
            Next j
        rArr(i, 1) = sArr2(i, 4) + nt - xt
        rArr(i, 2) = nt - xt
        rArr(i, 3) = n
        rArr(i, 4) = x
        rArr(i, 5) = rArr(i, 1) + n - x
    Next i
    [F8].Resize(lastRowDM - 1, 5).Value = rArr
    Columns("G:G").EntireColumn.Hidden = True
    Range("C4").Select
    Set sArr = Nothing
    Set sArr2 = Nothing
    Set rArr = Nothing
End If
End Sub

 

[ChanhTQ@]

Bạn tham khảo thêm macro sự kiện này:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [c5]) Is Nothing Then
    Dim Sh As Worksheet, Arr(), Cls As Range
    Dim MaND$, MaNC$
    Dim J&, TonDK#, Nhap#, Xuat#, HS%
    
    Set Sh = ThisWorkbook.Worksheets("CTiet")
    Arr() = Sh.[R2].CurrentRegion.Offset(1).Value
    MaND = TaoMa(Target.Offset(-1).Value)
    MaNC = TaoMa(Target.Value)
    J = [d8].CurrentRegion.Rows.Count
    Union([f8].Resize(J), [h8].Resize(J, 2)).ClearContents
    Application.ScreenUpdating = False
    For Each Cls In Range([b8], [b8].End(xlDown))
        For J = 1 To UBound(Arr())
            If Arr(J, 2) = Cls.Value Then
                If Left(Arr(J, 1), 3) < MaND Then
                    If InStr(Arr(J, 1), "N") Then HS = 1 Else HS = -1
                    Cls.Offset(, 4) = Cls.Offset(, 4).Value + HS * Arr(J, 5)
                ElseIf Left(Arr(J, 1), 3) >= MaND And Left(Arr(J, 1), 3) <= MaNC Then
                    If InStr(Arr(J, 1), "N") Then HS = 0 Else HS = 1
                    Cls.Offset(, 6 + HS) = Cls.Offset(, 6 + HS).Value + Arr(J, 5)
                End If
            End If
        Next J
    Next Cls
    Application.ScreenUpdating = True
 End If
End Sub

 

[SA_DQ]

Bài tập 6: Sửa số liệu đã nhập ở 1 fiếu nào đó trong CSDL

Một CSDL sẽ đảm bảo an toàn hơn 1 khi ta không nhập trực tiếp dữ liệu lên nó.
Điều này chúng ta đã áp dụng bằng việc lấy 1 trang tính làm Form nhập liệu & nhờ macro chuyển dữ liệu vô CSDL.

Nhưng trong quá trình vận hành CSDL, tất iếu cần chỉnh sửa số liệu bỡi 1 lí do hoặc chủ quan (nhập nhằm không fát hiện sớm) hay khách quan (do nhà cung cấp đổi số lượng,. . .), . . .
Vẫn theo nguyên tắc đảm bảo an toàn cho CSDL là trên hết, chúng ta nên lấy 1 trang tính mới để làm công việc chỉnh sửa. (Thực ra chúng ta cũng có thể lấy trang 'NX' cũng được, nhưng dễ có nguy cơ hư CSDL do trình độ chúng ta còn bất cập)

Chúng ta bắt đầu với trang tính mới &
thiết kế tương tư như hình.

Khi ta nhập 1 ngày bất kì vô [C3] thi macro sự kiện sẽ hiện toàn bộ các fiếu nhập & fiếu xuất trong ngày đó ở cột trống [H:H] (Ở đây ta coi như ngày đó có fiếu cần điều chỉnh số liệu.)
Ta lấy 1 trong các số fiếu hiển thị đem nhập vô [c4] thì,
1 macro sự kêện khác tại đây sẽ liệt kê toàn bộ nội dung của fiếu ở vùng chi tiết.

[Tiến hành sửa chữa số liệu bảng ghi vừa hiện]

Sau đó ta bấm vô nút 'Luu' thì kết quả các chi tiết của fiếu trước đây đã nhập sẽ bị xóa & các chi tiết mới sẽ được nạp vô CSDL.

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

 

[doveandrose]

thêm cũng như sửa , sửa cũng là thêm

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$3" Or Target.Address = "$D$3" Then
    CreateValidateC4
End If
If Target.Address = "$C$4" Then
    Dim lr As Long, wsCT As Worksheet, wsNX As Worksheet
    Set wsNX = Worksheets("NX")
    Set wsCT = Worksheets("CTiet")
    wsNX.[B10:B109].ClearContents
    wsNX.[E10:E109].ClearContents
    With wsCT
        lr = .[R65000].End(xlUp).Row + 1
        .Range("R1:W" & lr).AutoFilter 1, wsNX.[C4].Value
        If .[R65000].End(xlUp).Row > 1 Then
            .Range("S2:S" & lr).SpecialCells(xlCellTypeVisible).Copy wsNX.[B10]
            .Range("V2:V" & lr).SpecialCells(xlCellTypeVisible).Copy wsNX.[E10]
        End If
        .[A1].AutoFilter
    End With
End If
End Sub

Private Sub MyCmd_Click()
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, adrDl As String
With Worksheets("NX")
    If WorksheetFunction.Trim(.[C4].Value) = "" Then
        MsgBox "hello world"
        Exit Sub
    End If
    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 = .[B65000].End(xlUp).Row + 1
        If TypeName(Application.Match(tpArr(1, 2), .Range("C1:C" & lr), 0)) = "Error" Then
            .Range("B" & lr & ":C" & lr).Value = tpArr
        End If
        lr = .[R65000].End(xlUp).Row + 1
        .Range("R1:W" & lr).AutoFilter 1, tpArr(1, 2)
        If .[R65000].End(xlUp).Row > 1 Then
            adrDl = .Range("R2:W" & lr).SpecialCells(xlCellTypeVisible).Address
        End If
        .[A1].AutoFilter
        If adrDl <> "" Then .Range(adrDl).Delete xlUp
        lr = .[R65000].End(xlUp).Row + 1
        .Range("R" & lr & ":V" & (lr + n - 1)).Value = ctpArr
    End With
    Worksheets("NX").Range("B10:B109").ClearContents
    Worksheets("NX").Range("E10:E109").ClearContents
End If
CreateValidateC4
End Sub

Public Sub CreateValidateC4()
Dim Msn As String, wsNX As Worksheet, wsCT As Worksheet
Dim lr As Long, r As Long, arrValidate(1 To 1000) As String, arr As Variant
Set wsNX = Worksheets("NX")
Set wsCT = Worksheets("CTiet")
Application.ScreenUpdating = False
With wsCT
    wsNX.[K1:L1].Value = .[C1].Value
    lr = .[B65000].End(xlUp).Row + 1
    Msn = TaoMa(wsNX.[C3].Value) & wsNX.[D3]
    wsNX.[k2].Value = Msn & "*"
    .Range("C1:C" & lr).AdvancedFilter xlFilterCopy, wsNX.[K1:K2], wsNX.[L1]
End With


With wsNX
    If .[L2].Value <> "" Then
        lr = .[L1].End(xlDown).Row
        .[L1].Value = Msn & Format(Val(Right(.Range("L" & lr).Value, 3) + 1), "000")
    Else
        .[L1].Value = Msn & "001"
        lr = 1
    End If
    For r = 1 To lr Step 1
        arrValidate(r) = .Range("L" & r)
    Next
    .[C4].Validation.Delete
    .[C4].Validation.Add xlValidateList, xlValidAlertStop, , Join(arrValidate, ",")
    .[C4].Value = .[L1].Value
    .[K1].CurrentRegion.ClearContents
End With
Application.ScreenUpdating = True
End Sub

 

[Vo Tinh]

Khi ta nhập 1 ngày bất kì vô [C3] thi macro sự kiện sẽ hiện toàn bộ các fiếu nhập & fiếu xuất trong ngày đó ở cột trống [H:H] (Ở đây ta coi như ngày đó có fiếu cần điều chỉnh số liệu.)
Ta lấy 1 trong các số fiếu hiển thị đem nhập vô [c4] thì,
1 macro sự kêện khác tại đây sẽ liệt kê toàn bộ nội dung của fiếu ở vùng chi tiết.
[Tiến hành sửa chữa số liệu bảng ghi vừa hiện]
Sau đó ta bấm vô nút 'Luu' thì kết quả các chi tiết của fiếu trước đây đã nhập sẽ bị xóa & các chi tiết mới sẽ được nạp vô CSDL.
Chúc các bạn thành công!

Em cũng xin nộp bài Bác Sa và các AC xem giúp.
Trên sheet sử dụng các vùng tạm :
- [J1:J2] : điều kiện "số phiếu" để lọc AF với J2 = C4
- [L1:L ..]: row của các record nhằm định vị dòng chép ngược dữ liệu chỉnh sửa vào lại CTiet

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C3]) Is Nothing Then
    Dim myRg As Range, i As Long
    Dim myRg2 As Range, k%, rgRow As Range, lastRow As Integer
    Set myRg = Sheets("CTiet").[B2].CurrentRegion
    [H1].CurrentRegion.Offset(1, 0).ClearContents
    [C4].Value = ""
        For i = 2 To myRg.Rows.Count
            If myRg(i, 1) = [C3] Then
            k = k + 1
            [H1].Offset(k, 0).Value = myRg(i, 2).Value
            End If
        Next i
ElseIf Not Intersect(Target, [C4]) Is Nothing Then
    Set myRg2 = Sheets("CTiet").[R1].CurrentRegion
    lastRow = myRg2.Rows.Count
    Union(Range("B10:B" & lastRow), Range("E10:E" & lastRow)).ClearContents
    [J1] = myRg2(1, 1).Value 
    myRg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[B9], Unique:=False
    myRg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[E9], Unique:=False
    [L1].CurrentRegion.Offset(1, 0).ClearContents
        For i = 1 To lastRow
            If myRg2(i, 1) = [C4] Then
                k = k + 1
                [L1].Offset(k, 0) = i
            End If
        Next i
End If
End Sub

Private Sub CommandButton1_Click()Dim rW As Long, myRg As Range, myRg2 As Range, myRg3 As Range, sh As Worksheet
Dim i As Integer, j As Integer
Set sh = Sheets("SuaDL")
If [B10] = "" Then Exit Sub
rW = [L1].CurrentRegion.Rows.Count
    Set myRg = sh.Range("L2:L" & rW)
    Set myRg2 = sh.Range("B10:E" & rW + 10)
    Set myRg3 = Sheets("CTiet").[R1].CurrentRegion
        For i = 1 To myRg.Rows.Count
            For j = 1 To 4
                myRg3(myRg(i, 1), j + 1) = myRg2(i, j).Value
            Next j
        Next i
End Sub

 

[SA_DQ]

[Bài đọc thêm]

Fần macro sự kiện được trính dẫn dưới đây là để liệt kế các số fiếu nhập cũng như xuất có trong ngày cần tìm.

 Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C3]) Is Nothing Then
    Dim myRg As Range, i As Long
    Dim myRg2 As Range, k%, rgRow As Range, lastRow As Integer
    Set myRg = Sheets("CTiet").[B2].CurrentRegion
    [H1].CurrentRegion.Offset(1, 0).ClearContents
    [C4].Value = ""
        For i = 2 To myRg.Rows.Count
            If myRg(i, 1) = [C3] Then
            k = k + 1
            [H1].Offset(k, 0).Value = myRg(i, 2).Value
            End If
        Next i
ElseIf Not Intersect(Target, [C4]) Is Nothing Then
   ‘. . . . . . ‘
End If
End Sub

Tuy nhiên nếu cần chạy macro này ở giai đoạn cuối năm, khi mà số fiếu là độ sộ thì sẽ là lâu.
Lí do lâu là bạn xài vòng lặp duyệt từ ngày đầu đền ngày cuối, tất tần tật, không sót tên nào.

Nhưng có cách những khác sẽ cải thiện tốc độ đáng kể, trong đó có 1 cách trong tầm tay của bạn đó là áp dụng fương thức tìm kiếm (FIND method; bạn có thể tìm hiểu qua loạt bài của HoangDanh282VN tại địa chỉ: http://www.giaiphapexcel.com/forum/...ợp-về-phương-thức-tìm-kiếm-FIND-(Find-Method) )

Nhưng khoan hãy đọc hết nó lúc này, Mình xin chắc lọc ra những cái thiết iếu cho bạn lúc này, đó là:
Không nên tìm theo ngày đã định (với bạn lúc này), mà nên tìm chuỗi biểu thị ngày đã được hàm tự tạo mã hóa số liệu ngày ở cột bên fải cột ghi ngày. Tất nhiên lúc này ta cần áp dụng tìm với tham biến xlPart (chứ không xài xlWhole)
Tại sao lại đi vòng vo làm vậy: Vì tìm số liệu ngày tháng khó hơn rất nhiều so với số liệu kiểu khác (ngày-tháng-năm) hay dữ liệu kiểu chuỗi, ngay cả với mình cũng có lúc nhầm lẫn.

Thật ra trong file nào đó ở trên chúng ta đã gặp macro này:

 Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rng As Range, sRng As Range, Sh As Worksheet, MyAdd$
 
 If Not Intersect(Target, [D3]) Is Nothing Then
    Union([H1:H999], [C4]).ClearContents
    Set Sh = ThisWorkbook.Worksheets("CTiet")
    Set Rng = Sh.Range(Sh.[C1], Sh.[C1].End(xlDown))
    Set sRng = Rng.Find(TaoMa([C3].Value) & Target.Value, , xlFormulas, xlPart)
    If sRng Is Nothing Then
        [C4].Value = TaoMa([C3].Value) & Target.Value & "001"
    Else
        MyAdd = sRng.Address
        Do
            [h999].End(xlUp).Offset(1).Value = sRng.Value
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 End If
End Sub

Lúc rỗi bạn thử giành thời gian cho nó xem sao. Tuy có vẻ dài vì nhiều dòng lệnh hơn, nhưng đảm bảo nhanh hơn vòng lặp bên trên. (Vì lí do đơn giản là nó sẽ chỉ nhảy cóc từ ô được tìm thấy này đến ô được tìm thấy khác)

 

[Vo Tinh]

Em làm lại theo phương thức FIND, cám ơn chia sẻ của Bác

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C3]) Is Nothing Then
    Dim myrg As Range, smyRg As Range, i As Long, sh As Worksheet
    Dim myrg2 As Range, k As Integer, lastRow As Integer, myRow As Long
    Set sh = ThisWorkbook.Worksheets("CTiet")
    Set myrg = sh.Range(sh.[C2], sh.[C2].End(xlDown))
    [H1].CurrentRegion.Offset(1, 0).ClearContents
    [C4].Value = ""
    Set smyRg = myrg.Find(TaoMa([C3]), , LookIn:=xlValues, LookAt:=xlPart)
        If Not smyRg Is Nothing Then
        myRow = smyRg.Row
        Do
            k = k + 1
            [H1].Offset(k, 0).Value = smyRg
            Set smyRg = myrg.FindNext(smyRg)
        Loop While smyRg.Row <> myRow
        End If
ElseIf Not Intersect(Target, [C4]) Is Nothing Then
    Set myrg2 = sh.[R1].CurrentRegion
    lastRow = myrg2.Rows.Count
    Union(Range("B10:B" & lastRow), Range("E10:E" & lastRow)).ClearContents
    [L1].CurrentRegion.Offset(1, 0).ClearContents
    [J1] = myrg2(1, 1).Value
    If [C4].Value = "" Then Exit Sub
    myrg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[B9], Unique:=False
    myrg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[E9], Unique:=False
    Set smyRg = myrg2.Find([C4], , LookIn:=xlValues, LookAt:=xlWhole)
        If Not smyRg Is Nothing Then
            Do
                k = k + 1
                [L1].Offset(k, 0).Value = smyRg.Row
            Set smyRg = myrg2.FindNext(smyRg)
            Loop While smyRg.Row <> [L2]
        End If
End If
End Sub

 

[SA_DQ]

1 lưu í với bạn, tuy nhỏ:

Nếu bạn xài câu lệnh

Option Explicit

Thì macro của bạn sẽ báo lỗi.

Với mình thì luôn xài câu lệnh này!

 

[Let'GâuGâu]

Nếu bạn xài câu lệnh

Option Explicit

Thì macro của bạn sẽ báo lỗi.

Với mình thì luôn xài câu lệnh này!

cho em hỏi, vì sao phải xài dòng lệnh này vậy
em thấy một số vị, viết code chuyên nghiệp hay dùng nó, nhưng ko hiểu tác dụng để làm gì?, vì bỏ nó code vẫn chạy mà?

 

[chuot0106]

cho em hỏi, vì sao phải xài dòng lệnh này vậy
em thấy một số vị, viết code chuyên nghiệp hay dùng nó, nhưng ko hiểu tác dụng để làm gì?, vì bỏ nó code vẫn chạy mà?

Theo cách hiểu nông cạn của tôi thì nếu bỏ dòng lệnh này đi thì trong sub không cần khai báo biến thì code vẫn chạy và ko báo lỗi. Còn nếu có dòng lệnh này thì ngược lại.

 

[Vo Tinh]

Nếu bạn xài câu lệnh

Option Explicit

Thì macro của bạn sẽ báo lỗi.

Với mình thì luôn xài câu lệnh này!

Đã kiểm tra lại đúng là báo lỗi.
Do khi post bài lên lúc xem lại thì sửa Sheets("CTiet") thành sh
Em sửa lại rồi và macro chạy được nhưng chưa hiểu tại sao vì mình đã Set sh rồi mà vẫn bị lỗi như thế.
Cám ơn Bác

Sửa dòng này

Set myrg2 =[COLOR=#ff0000] sh[/COLOR].[R1].CurrentRegion

Thành dòng này

Set myrg2 = [COLOR=#ff0000]Sheets("CTiet")[/COLOR].[R1].CurrentRegion

 

[ChanhTQ@]

Một điều hiển nhiên rằng nếu không có dòng lệnh đó thì nó - VBA không báo cho ta lỗi tiềm ẩn. Rằng bạn Vo Tinh chỉ khai báo biến cho 1 vùng lệnh, mà chưa khai biến cho toàn bộ macro.

Nếu cho là mình chưa qua trường lớp thì không thể làm code theo kiểu tài tử được; Mọi cái nên tường minh, không huyễn hoặc bản thân được

Rồi 1 chục năm sau, khi đọc lại code của mình mà như đọc lại code của ai xa lạ!

Tuy ta tiết kiệm được 1 vài fút hiện tại, nhưng sau này sẽ tốn nhiều hơn bội lần khi đọc lại nó.

Nhưng dù sao đó cũng là thói quen của từng người, tùy vậy, . . . .

 

[phihndhsp]

cho em hỏi, vì sao phải xài dòng lệnh này vậy
em thấy một số vị, viết code chuyên nghiệp hay dùng nó, nhưng ko hiểu tác dụng để làm gì?, vì bỏ nó code vẫn chạy mà?

Nếu có câu lệnh đó thì VBA bảo rằng mọi biến được xài thì phải được khai báo. Và khai báo biến trước khi sử dụng sẽ giúp người lập trình dễ kiểm soát chương trình hơn. Nếu có câu lệnh đó mà không khai báo biến trước khi dùng thì chương trình sẽ báo lỗi. Chính vì báo lỗi nên các thành viên thường bỏ nó đi, đó là một sai lầm lớn trong lập trình. Và nó sẽ làm cho đoạn code của mình khó đọc và khó kiểm soát

 

[VetMini]

cho em hỏi, vì sao phải xài dòng lệnh này vậy
em thấy một số vị, viết code chuyên nghiệp hay dùng nó, nhưng ko hiểu tác dụng để làm gì?, vì bỏ nó code vẫn chạy mà?

Đỏ: không ai bắt bạn phải xài cả. Lý do tại sao người ta hay xài thì cứ xem tiếp.
Xanh: đối với người code chuyên nghiệp, từ "vẫn chạy" không có nghĩa lý gì cả. Bởi vì code có thể chạy ầm ầm nhưng kết quả sai bấy.

Có hai lý do NÊN dùng dòng lệnh ấy:

1. Nó giúp cho bạn loại trừ được một số trường hợp gõ sai chính tả
Ví dụ bạn có biến tongHop, ở một dòng nào đó bạn gõ nhâm thành tongHip.
tongHop = 1000
For i = 1 to 10
tongHip = tongHop + 1
Next i
Nếu không có lệnh buộc khai báo thì VBA mặc nhiên coi tongHip là một biến mới. Và kết quả cuối cùng của bạn là tongHop = 1000, thay vì 1010 mới đúng
Nếu có lệnh buộc khai báo thì VBA sẽ báo lỗi cho bạn kịp thời sửa
Lưu ý là tôi chỉ nói "một số trường hợp", không phải tất cả. Tuy vậy, kinh nghiệm tôi thấy nó giúp tôi tránh lỗi đến gần 90%. Rất xứng đáng dùng.

2. Khai báo biến tường minh không hẳn là để 10 năm sau đọc lại như nhiều người nghĩ. Việc khai báo biến tường minh giúp bạn tránh bị lẫn lộn giữa biến toàn cục và biến nội bộ.
Ví dụ đầu module bạn khai một biến tumLum thì trong tất cả các sub có sử dụng tumLum:
- sub nào có khai tumLum thì đây là biến riêng của nó, chả liên quan gì đến biến tumLum khai ở trên.
- sub nào không có khai tumLum mà sử dụng tumLum thì mặc nhiên là nó sử dụng biến toàn cục khai ở trên.
Nếu biến toàn cục được khai là public thì càng nguy hiểm hơn nữa. Ở một sub nào đó, bạn có thể sử dụng biên tumLum mà không biết rằng nó gây ảnh hưởng đến các sub khác. Nếu bạn có khai bào tumLum trong sub của mình thì bạn có thể yên tâm là không ai bị ảnh hưởng cả.

 

[Kiều Mạnh]

Theo mình nghĩ đơn giản là vầy
phải xài dòng lệnh này Option Explicit
Thì khi viết code phải khai báo tường minh nó giúp cho mình rất nhiều về chính tả ...nếu viết bỏ bớt ngắn gọn không khai báo tường minh.... nếu bạn nào đó copy qua máy khác có Option Explicit là lỗi code...
khi viết code có Option Explicit thì có từ gợi ý và code chạy nhanh hơn một tẹo ....còn không thì ...

Ví dụ Sau nếu có Option Explicit thì sub sau phải Dim nọ Dim kia nếu không là lỗi còn nếu Dim đầy đấy đủ hết thì có Option Explicit hay không nó vẫn chạy

Sub ViDu()
    n = [A1:C20].Value
    [J1].Resize(UBound(n), 3) = n
End Sub

 

[SA_DQ]

Em làm lại theo phương thức FIND, cám ơn chia sẻ của Bác

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C3]) Is Nothing Then
Dim myrg As Range, smyRg As Range, i As Long, sh As Worksheet
Dim myrg2 As Range, k As Integer, lastRow As Integer, myRow As Long
Set sh = ThisWorkbook.Worksheets("CTiet")
Set myrg = sh.Range(sh.[C2], sh.[C2].End(xlDown))
[H1].CurrentRegion.Offset(1, 0).ClearContents
[C4].Value = ""
Set smyRg = myrg.Find(TaoMa([C3]), , LookIn:=xlValues, LookAt:=xlPart)
If Not smyRg Is Nothing Then
myRow = smyRg.Row
Do
k = k + 1
[H1].Offset(k, 0).Value = smyRg
Set smyRg = myrg.FindNext(smyRg)
Loop While smyRg.Row <> myRow
End If
'. . . . . '
End Sub

Ngoài ra còn 1 con dao bén hơn nữa để xài trong trường hợp này; Đó là đưa dữ liệu cần tìm vô biến mãng thích hợp & duyệt trên mảng.
Việc này chúng ta đã đề cập ở vài bài nào đó bên trên.

Nếu không bận lắm, ngày cuối tuần hôm nay bạn thử xài con dao fẩu này xem sao!?!

(húc nhiều thành công!

 

[SA_DQ]

Hình như đoạn "code" này ở bài #47 đang có vấn đề cần rút gọn

ElseIf Not Intersect(Target, [C4]) Is Nothing Then
    Set myrg2 = sh.[R1].CurrentRegion
    lastRow = myrg2.Rows.Count
    Union(Range("B10:B" & lastRow), Range("E10:E" & lastRow)).ClearContents
    [L1].CurrentRegion.Offset(1, 0).ClearContents
    [J1] = myrg2(1, 1).Value
    If [C4].Value = "" Then Exit Sub
    myrg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[B9], Unique:=False
    myrg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[E9], Unique:=False
    Set smyRg = myrg2.Find([C4], , LookIn:=xlValues, LookAt:=xlWhole)
        If Not smyRg Is Nothing Then
            Do
                k = k + 1
                [L1].Offset(k, 0).Value = smyRg.Row
            Set smyRg = myrg2.FindNext(smyRg)
            Loop While smyRg.Row <> [L2]
        End If
End If

Theo mình chỉ cần lọc 1 lần & đưa vô vùng kết quả là được:

 ElseIf Not Intersect(Target, [C4]) Is Nothing Then
    If [C4].Value = "" Then Exit Sub
    Set Sh = ThisWorkbook.Worksheets("CTiet")
    Set Rng = Sh.[R1].CurrentRegion
    lastRow = Rng.Rows.Count
    [b10].Resize(16, 4).ClearContents
    Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], _
        CopyToRange:=[B9].Resize(, 4), Unique:=False
 End If

 

[Vo Tinh]

Thực tế thì hiện nay em luôn dùng Option Explicit
Cũng chính vì bị sai chính tả tên biến trong quá trình viết code vài lần và khi đọc code để học hỏi mà không thấy khai báo biến thì khó hiểu hơn, từ đó em set luôn Option Explicit trong Option.
Cũng nhờ sự cố vừa rồi em biết thêm biến có biến toàn macro, có biến chỉ cho 1 đoạn code do vị trí mình khai báo biến, rất cám ơn Bác và các AC đã chia sẻ.

Ngoài ra còn 1 con dao bén hơn nữa để xài trong trường hợp này; Đó là đưa dữ liệu cần tìm vô biến mãng thích hợp & duyệt trên mảng.
Việc này chúng ta đã đề cập ở vài bài nào đó bên trên.

Em thử làm mảng thế này mà không biết có phải là con dao bén không nữa

Private Sub Worksheet_Change(ByVal Target As Range)    
    Dim myRg As Range, smyRg As Range, i As Long, sh As Worksheet, sArr, sArr2, rArr, rArr2
    Dim myRg2 As Range, k As Integer, lastRow As Integer, myRow As Long
    Set sh = ThisWorkbook.Worksheets("CTiet")
    Set myRg = sh.Range(sh.[C2], sh.[C2].End(xlDown))
    Set myRg2 = sh.[R1].CurrentRegion
    lastRow = myRg2.Rows.Count
If Not Intersect(Target, [C3]) Is Nothing Then
    ReDim sArr(1 To myRg.Rows.Count)
    Set sArr = myRg
    ReDim rArr(1 To 1)
    [H1].CurrentRegion.Offset(1, 0).ClearContents
    [C4].Value = ""
    Set smyRg = sArr.Find(TaoMa([C3]), , LookIn:=xlValues, LookAt:=xlPart)
        If Not smyRg Is Nothing Then
            myRow = smyRg.Row
                Do
                    k = k + 1
                    ReDim Preserve rArr(1 To k)
                        rArr(k) = smyRg
                    Set smyRg = sArr.FindNext(smyRg)
                Loop While smyRg.Row <> myRow
            [H2].Resize(k) = WorksheetFunction.Transpose(rArr)
        End If
ElseIf Not Intersect(Target, [C4]) Is Nothing Then
    Union(Range("B10:B" & lastRow), Range("E10:E" & lastRow)).ClearContents
    [L1].CurrentRegion.Offset(1, 0).ClearContents
    [J1] = myRg2(1, 1).Value
        If [C4].Value = "" Then Exit Sub
            myRg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[B9], Unique:=False
            myRg2.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], CopyToRange:=[E9], Unique:=False
            ReDim sArr2(1 To myRg2.Rows.Count, 6)
            Set sArr2 = myRg2
            ReDim rArr2(1 To 1)
            Set smyRg = sArr2.Find([C4], , LookIn:=xlValues, LookAt:=xlWhole)
                If Not smyRg Is Nothing Then
                    myRow = smyRg.Row
                    Do
                        k = k + 1
                        ReDim Preserve rArr2(1 To k)
                            rArr2(k) = smyRg.Row
                            [L2].Resize(k) = WorksheetFunction.Transpose(rArr2)
                        Set smyRg = sArr2.FindNext(smyRg)
                    Loop While smyRg.Row <> myRow
                End If
        End If
End Sub

 

[Vo Tinh]

Hình như đoạn "code" này ở bài #47 đang có vấn đề cần rút gọn

Theo mình chỉ cần lọc 1 lần & đưa vô vùng kết quả là được:

 ElseIf Not Intersect(Target, [C4]) Is Nothing Then
    If [C4].Value = "" Then Exit Sub
    Set Sh = ThisWorkbook.Worksheets("CTiet")
    Set Rng = Sh.[R1].CurrentRegion
    lastRow = Rng.Rows.Count
    [b10].Resize(16, 4).ClearContents
    Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[J1:J2], _
        CopyToRange:=[B9].Resize(, 4), Unique:=False
 End If

Em cũng có nghĩ tới việc này nhưng theo em thì chỉ nên lọc Mã và Số lượng sang, từ Mã này dùng Vlookup trên sheet lấy 2 trường kia nhằm tránh trường hợp người dùng sửa sai Mã hoặc sai tên sau đó copy ngược vào CTiet sẽ hư mất dữ liệu.

Cám ơn Bác nhiều mong Bác vẫn hướng dẫn chia sẻ tiếp, em có đọc về VBA nhưng viết code thì Topic này là bắt đầu đấy Bác à, sau một tuần nhìn lại với các bài code thấy mình học được rất nhiều thứ từ Bác và các AC.

 

[doveandrose]

làm sao dùng lệnh ADO để xóa dòng dữ liệu

em xin hỏi : ta có thể dùng lệnh ADO để xóa 1 dòng dữ liệu được không ?
trong file dưới đây , lệnh Delete bị báo
Deleting data in a linked table is not supported by this ISAM
khi bấm vào nút "copy to" trong sheet "NX"
các thầy vui lòng sửa giúp . cảm ơn

 

[loinguyen212]

Tại sao đến đây lại chững lại, mọi người tiếp tục đi ạ.

Ngoài ra còn 1 con dao bén hơn nữa để xài trong trường hợp này; Đó là đưa dữ liệu cần tìm vô biến mãng thích hợp & duyệt trên mảng.

Bác HYen nói thêm về cái này được không??

 

[Hai Lúa Miền Tây]

em xin hỏi : ta có thể dùng lệnh ADO để xóa 1 dòng dữ liệu được không ?
trong file dưới đây , lệnh Delete bị báo
Deleting data in a linked table is not supported by this ISAM
khi bấm vào nút "copy to" trong sheet "NX"
các thầy vui lòng sửa giúp . cảm ơn

Excel ADO Không hỗ trợ việc dùng câu lệnh delete. Bạn nên dùng cách khác.