Nhờ viết Code để thay thế công thức tạo số thứ tự (1 người xem)

[dongducnhiem]

Chào các bạn!
Tôi đã viết công thức tạo số phiếu thu, chi, nhập, xuất. Nhưng do Cơ sở dữ liệu nhiều nên File chạy chậm. Nên mong các bạn dựa vào công thức trong file để viết giùm tôi code có thể chạy nhanh hơn.
Tôi cũng đã tìm trên GPE, nhưng do công thức fức tạp nên cũng chưa tìm được bài tương ứng, nên rất mong các bạn giúp đỡ
Tôi muốn code thể hiện kết quả ở Cột C và D để thay thế công thức ở các cột C, D và các cột phụ Q, R, S, T, U, V (Xem file đính kèm)
Rất mong được quan tâm & giúp đỡ của các bạn, cảm ơn!
P/s: Tôi đang sử dụng Excel 2003

 

[concogia]

Hihi, xài của Ba Tê hay cái này đều được

Public Sub LaiPhieuNX()
    Dim Vung, I, doNX, iThang, Gom, Kt, Mg, K, kK, A, B, KtDau
        Vung = Range([B8], [B50000].End(xlUp)).Resize(, 8)
        ReDim Mg(1 To UBound(Vung), 1 To 1)
        doNX = "152 153 155 1561"
        Mg(1, 1) = "So NX"
            For I = 2 To UBound(Vung)
                If Vung(I, 1) <> "" Then
                    A = Vung(I, 1) & Vung(I, 4) & Vung(I, 5) & Vung(I, 6)
                    B = Vung(I - 1, 1) & Vung(I - 1, 4) & Vung(I - 1, 5) & Vung(I - 1, 6)
                        If A = B And Mg(I - 1, 1) <> "" Then
                            KtDau = Left(Mg(I - 1, 1), 1)
                            If InStr(doNX, Vung(I, 7)) = 0 And InStr(doNX, Vung(I, 8)) = 0 Then
                                Mg(I, 1) = ""
                            ElseIf KtDau = "N" And InStr(doNX, Vung(I, 7)) Then
                                Mg(I, 1) = Mg(I - 1, 1)
                            ElseIf KtDau = "N" And InStr(doNX, Vung(I, 8)) Then
                                kK = kK + 1
                                Mg(I, 1) = "X" & Right("00" & kK, 3) & "/" & iThang
                            ElseIf KtDau = "X" And InStr(doNX, Vung(I, 8)) Then
                                Mg(I, 1) = Mg(I - 1, 1)
                            Else
                                K = K + 1
                                Mg(I, 1) = "N" & Right("00" & K, 3) & "/" & iThang
                            End If
                        Else
                            If Val(Right(Vung(I, 2), 2)) > iThang Then iThang = Val(Right(Vung(I, 2), 2)): K = 0: kK = 0
                                If InStr(doNX, Vung(I, 7)) Then
                                    K = K + 1
                                    Mg(I, 1) = "N" & Right("00" & K, 3) & "/" & iThang
                                ElseIf InStr(doNX, Vung(I, 8)) Then
                                    kK = kK + 1
                                    Mg(I, 1) = "X" & Right("00" & kK, 3) & "/" & iThang
                                End If
                        End If
                End If
            Next I
    [O8].Resize(UBound(Vung)) = Mg
End Sub

Híc, mình nghi là đúng mà (3 dòng 23, 24, 25 mâu thuẫn với yêu cầu bài trước)
Thân

 

[dongducnhiem]

Đúng là ví dụ cũng chưa hết các trường hợp.
Thử lại cái này lu bu hơn một chút.
Tôi cho kết quả ở cột J cho bạn so sánh.
-------------

Public Sub GPE3T()
Dim Dic As Object, sArr(), dArr(), I As Long, NumN As Long, NumX As Long, Tem As String, Str As String, Thang As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Array(152, 153, 155, 1561)
For I = 0 To UBound(sArr)
    If Not Dic.Exists(sArr(I)) Then Dic.Add sArr(I), "GiaiPhapExcel"
Next I
sArr = Range([B8], [B65536].End(xlUp)).Resize(, 8).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 2 To UBound(sArr, 1)
    If sArr(I, 1) <> Empty And Month(sArr(I, 1)) <> Thang Then
        NumN = 0: NumX = 0
        Thang = Month(sArr(I, 1))
    End If
        Str = sArr(I - 1, 1) & sArr(I - 1, 4) & sArr(I - 1, 5) & sArr(I - 1, 6)
        Tem = sArr(I, 1) & sArr(I, 4) & sArr(I, 5) & sArr(I, 6)
    If Tem <> Str Then
        If Dic.Exists(sArr(I, 7)) Then NumN = NumN + 1
        If Dic.Exists(sArr(I, 8)) Then NumX = NumX + 1
    Else
        If Dic.Exists(sArr(I, 7)) And Not Dic.Exists(sArr(I - 1, 7)) Then NumN = NumN + 1
        If Dic.Exists(sArr(I, 8)) And Not Dic.Exists(sArr(I - 1, 8)) Then NumX = NumX + 1
    End If
        If Dic.Exists(sArr(I, 7)) Then dArr(I - 1, 1) = "N" & Format(NumN, "000") & "/" & Thang
        If Dic.Exists(sArr(I, 8)) Then dArr(I - 1, 1) = "X" & Format(NumX, "000") & "/" & Thang
Next I
[J9].Resize(I - 2) = dArr
Set Dic = Nothing
End Sub

------------
Thay [J9] bằng [A9] trong dòng này nếu xài được

[J9].Resize(I - 2) = dArr

Hiện nay code đã chạy rất tốt.
anh cho tôi hỏi:
1/ Trường hợp chưa có phát sinh nhập xuất gì hết thì khi chạy code nó báo lỗi, vậy ta fải thêm gì? để nó không báo lỗi nữa!
2/ Trong code có câu lệnh "GiaiPhapExcel" hiểu nó có tác dụng gì?
---------------
Cảm ơn anh!

 

[Ba Tê]

Hiện nay code đã chạy rất tốt.
anh cho tôi hỏi:
1/ Trường hợp chưa có phát sinh nhập xuất gì hết thì khi chạy code nó báo lỗi, vậy ta fải thêm gì? để nó không báo lỗi nữa!
2/ Trong code có câu lệnh "GiaiPhapExcel" hiểu nó có tác dụng gì?
---------------
Cảm ơn anh!

1/ Má ơi! Không có dữ liệu gì hết mà cho chạy làm gì?
Đưa cái này vào tuốt bên trên dưới dòng Public Sub GPE3T()

If [B65536].End(xlUp).Row <= 8 Then
    MsgBox "Má ơi! Không có dữ liệu xin đừng phá tui!"
    Exit Sub
End If

2/ "GiaiPhapExcel" là "Giải Pháp Excel" thôi!
Bạn hỏi tại sao tên Sub là GPE3T() tui cũng thua luôn.

 

[dongducnhiem]

1/ Má ơi! Không có dữ liệu gì hết mà cho chạy làm gì?
Đưa cái này vào tuốt bên trên

If [B65536].End(xlUp).Row <= 8 Then
    MsgBox "Má ơi! Không có dữ liệu xin đừng phá tui!"
    Exit Sub
End If

2/ "GiaiPhapExcel" là "Giải Pháp Excel" thôi!

Dĩ nhiên khi kg có dữ liệu thì kg chạy, nhưng do mình lồng code của bạn vào các code khác

Sub TH_all
Call [COLOR=#0000BB][FONT=monospace][I]GPE3T
[/I][/FONT][/COLOR]...
End  Sub

 

[Ba Tê]

Dĩ nhiên khi kg có dữ liệu thì kg chạy, nhưng do mình lồng code của bạn vào các code khác

Sub TH_all
Call [COLOR=#0000BB][FONT=monospace][I]GPE3T
[/I][/FONT][/COLOR]...
End  Sub

Code này chỉ chạy được khi sheet hiện hành là "nó" mà thôi, từ sheet khác mà chạy nó là "tèo".

 

[ngocthegian]

Em hỏi anh chủ topic, nay anh đang áp dụng code nào rồi ah, em ké với

 

[ngocthegian]

Em cũng đang làm bằng công thức, nhưng một số loại phiếu phải sửa riêng bằng tay , pkt đến số 1000 k hiểu sao không chịu chạy nữa.... cưa 1000 mãi ???