Nhờ anh chị sửa giúp Code VBA trong file đính kèm để cộng thêm thửa (1 người xem)

[baquang1984]

Sửa Code VBA trong file đính kèm để cộng thêm thửa

Ở Sheets"File1" em có tổng rất nhiều tờ bản đồ và mỗi tờ bản đồ gồm nhiều thửa
Khi thực hiện Code lọc dữ liệu tờ bản đồ của bác BaTe viết giúp lần trược thì ở cột tổng thửa sheets"So_MucKe" sẽ đếm được trong tờ bản đồ có bao nhiêu thửa và sẽ tính được tổng số trang in ra của tờ bản đồ đó ở cột thứ tự trang sheets"So_MucKe", một trang ở đây em cố định là 39 dòng.
Yêu cầu của chương trình: để làm sao cột tổng thửa ở sheets"So_MucKe" sẽ cộng thêm 1/3 số thửa của tờ bản đồ đó VD Tờ bản đồ số 1 tổng thửa là 9 thửa cộng thêm 1/3 số thửa của tờ bản đồ số 1 thì cột tổng thửa sẽ tăng lên thêm 3 thửa và cho ra kết quả là 12.
Và tử đó sẽ tính ra được số trang phải in thêm được là bao nhiêu dựa và cột tổng thửa sheets"So_MucKe"
Em cảm ơn mọi người giúp đỡ!

 

[baquang1984]

Nhở các cao thủ giúp em chương trình này với ạ
Em cảm ơn nhiều ạ!

 

[baquang1984]

Hixxx với đề tài này không biết em có lỗi gì về quy định của diễn đàn không mà có nhiều thành viên xem mà không thấy có phản hôi. Rất mong được sụ giúp đỡ của các thành viên trên diễn đang.
chúc diễn đàn ngày càng phát triển.

 

[vuivui85]

Hixxx với đề tài này không biết em có lỗi gì về quy định của diễn đàn không mà có nhiều thành viên xem mà không thấy có phản hôi. Rất mong được sụ giúp đỡ của các thành viên trên diễn đang.
chúc diễn đàn ngày càng phát triển.

Chắc là khó hiểu với giải thích của bạn, và thực vô lý khi cộng thêm 1/3 làm gì,

Làm tạm sửa lubuxu theo sub cũ của bạn như thế này, có gì thì kiểm tra thử xem có đúng ý của bạn không, tự kiểm tra vì tôi không có điều kiện kiểm tra .

Public Sub Loc_DS_ToBD_NEW()
Dim Dic As Object, I As Long, K As Long, sArr(), dArr()
Dim Tem As String, SoTrang As Long, Trang As Long

With Sheets("File1")
    sArr = .Range(.[A3], .[A65536].End(xlUp)).Offset(, 13).Value
End With

Set Dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To UBound(sArr, 1), 1 To 4)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Dic.Exists(Tem) Then
        dArr(Dic.Item(Tem), 4) = dArr(Dic.Item(Tem), 4) + 1
    Else
        K = K + 1
        Dic.Add Tem, K
        dArr(K, 1) = K
        dArr(K, 2) = sArr(I, 1)
        dArr(K, 4) = 1
    End If
Next I

SoTrang = 0
For I = 1 To K
    dArr(I, 4) = dArr(I, 4) + Int(dArr(I, 4) / 3)
    SoTrang = SoTrang + dArr(I, 4) \ 39 + IIf(dArr(I, 4) Mod 39 > 0, 1, 0)
    dArr(I, 3) = SoTrang
Next I

With Sheets("So_MucKe")
    .[A2:D65536].ClearContents
    .[A2].Resize(K, 4).Value = dArr
End With
Set Dic = Nothing
End Sub

 

[baquang1984]

Chắc là khó hiểu với giải thích của bạn, và thực vô lý khi cộng thêm 1/3 làm gì,

Làm tạm sửa lubuxu theo sub cũ của bạn như thế này, có gì thì kiểm tra thử xem có đúng ý của bạn không, tự kiểm tra vì tôi không có điều kiện kiểm tra .

Public Sub Loc_DS_ToBD_NEW()
Dim Dic As Object, I As Long, K As Long, sArr(), dArr()
Dim Tem As String, SoTrang As Long, Trang As Long

With Sheets("File1")
    sArr = .Range(.[A3], .[A65536].End(xlUp)).Offset(, 13).Value
End With

Set Dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To UBound(sArr, 1), 1 To 4)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Dic.Exists(Tem) Then
        dArr(Dic.Item(Tem), 4) = dArr(Dic.Item(Tem), 4) + 1
    Else
        K = K + 1
        Dic.Add Tem, K
        dArr(K, 1) = K
        dArr(K, 2) = sArr(I, 1)
        dArr(K, 4) = 1
    End If
Next I

SoTrang = 0
For I = 1 To K
    dArr(I, 4) = dArr(I, 4) + Int(dArr(I, 4) / 3)
    SoTrang = SoTrang + dArr(I, 4) \ 39 + IIf(dArr(I, 4) Mod 39 > 0, 1, 0)
    dArr(I, 3) = SoTrang
Next I

With Sheets("So_MucKe")
    .[A2:D65536].ClearContents
    .[A2].Resize(K, 4).Value = dArr
End With
Set Dic = Nothing
End Sub

Em cảm ơn anh vuivui85 đúng là em đang cần Code như thế này.
Lý do tại sao là cần phải cộng thêm 1/3 là để khi in ra chương trình sẽ tạo ra những trang trắng để in còn nếu để như Code ban đầu thì nó sẽ in ra các trang có số liệu còn những trang còn lại nó không in ạ
Thanks all!