Nhờ A/c viết giúp Em code tính phí lưu kho, bốc xếp (1 người xem)

[ndhmoney686]

Em chào A/c!
Em muốn nhờ A/c viết giúp Em code cho file tính chi phí lưu kho, bốc xếp.

• Về phí lưu kho: Điều kiện tính cho cột này, như sau: Nếu ô ở cột i có dữ liệu thì thôi ko tính. Còn không có dữ liệu thì tính theo điều kiện (nhập 15 ngày đầu tính 1 tháng, xuất từ ngày 16 tính 1 tháng. Nhập từ ngày 16 trở đi tính 1/2 tháng, xuất 15 ngày đầu tính 1/2 tháng)
• Về phí bốc xếp: Lấy cột số lượng x cột đơn giá

Em đang dùng công thức. Nhưng dữ liệu nhiều dần lên về cuối năm. Thì file hay bị chậm. Mong A/c giúp đỡ. Xin trân thành cám ơn A/c nhiều!

 

[Hoang2013]

Nếu bạn muốn viết macro sự kiện, thì trong thiết kế CSDL, bạn phải đổi chổ cho nhau giữa 2 cột [Tự nhập] & [Đơn giá]

 

[ndhmoney686]

Nếu bạn muốn viết macro sự kiện, thì trong thiết kế CSDL, bạn phải đổi chổ cho nhau giữa 2 cột [Tự nhập] & [Đơn giá]

Được bạn ah. Bạn giúp mình với nhé. Cám ơn Bạn!

 

[Hoang2013]

Mình mới viết 2 cho 2 cột thôi;

Bạn đỗ dữ liệu vô & tiến hành kiểm tra xem kết quả giữa công thức & macro đưa ra có trùng khớp không.

Sẽ

 

[ndhmoney686]

Mình mới viết 2 cho 2 cột thôi;

Bạn đỗ dữ liệu vô & tiến hành kiểm tra xem kết quả giữa công thức & macro đưa ra có trùng khớp không.

Sẽ

Kết quả Ok bạn ah. Bạn giúp mình tiếp cột nhập với xuất với bạn nhé. Cám ơn Bạn!

 

[Hoang2013]

Bạn chép toàn bộ nội dung này đè hết lên macro sự kiện cũ

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rws As Long, Tmp As Double, DG As Double
 
 Rws = [B13].CurrentRegion.Rows.Count + 9
 If Not Intersect(Target, [I13].Resize(Rws + 9)) Is Nothing Then
    With Target
        DG = .Value
        If .Offset(, -1).Value > 0 Then
            .Offset(, 1).Resize(, 2).Value = 0
        Else
            .Offset(, 1).Value = (.Offset(, -5).Value + .Offset(, -4).Value) * DG / 2
            Tmp = (.Offset(, -6).Value + .Offset(, -5).Value) * DG
            If Tmp > 0 Then
                .Offset(, 2).Value = .Offset(, -6).Value * DG
            Else
                .Offset(, 2).Value = (.Offset(, -3).Value + .Offset(, -2).Value) * DG
            End If
        End If
    End With
 ElseIf Not Intersect(Target, [M13].Resize(Rws + 9)) Is Nothing Then    '*'
    GPE Target
'    With Target            '
'        .Offset(, 1).Value = .Offset(, -1).Value * .Value  '
'    End With               '
 ElseIf Not Intersect(Target, [P13].Resize(Rws + 9)) Is Nothing Then
    GPE Target
 ElseIf Not Intersect(Target, [S13].Resize(Rws + 9)) Is Nothing Then
    GPE Target                                                          '*'
 End If
End Sub

Sub GPE(Targ As Range)                                      '*'
    With Targ
        .Offset(, 1).Value = .Offset(, -1).Value * .Value
    End With
End Sub                                                     '*'

 

[ndhmoney686]

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rws As Long, Tmp As Double, DG As Double
 
 Rws = [B13].CurrentRegion.Rows.Count + 9
 If Not Intersect(Target, [I13].Resize(Rws + 9)) Is Nothing Then
    With Target
        DG = .Value
        If .Offset(, -1).Value > 0 Then
            .Offset(, 1).Resize(, 2).Value = 0
        Else
            .Offset(, 1).Value = (.Offset(, -5).Value + .Offset(, -4).Value) * DG / 2
            Tmp = (.Offset(, -6).Value + .Offset(, -5).Value) * DG
            If Tmp > 0 Then
                .Offset(, 2).Value = .Offset(, -6).Value * DG
            Else
                .Offset(, 2).Value = (.Offset(, -3).Value + .Offset(, -2).Value) * DG
            End If
        End If
    End With
 ElseIf Not Intersect(Target, [M13].Resize(Rws + 9)) Is Nothing Then    '*'
    GPE Target
'    With Target            '
'        .Offset(, 1).Value = .Offset(, -1).Value * .Value  '
'    End With               '
 ElseIf Not Intersect(Target, [P13].Resize(Rws + 9)) Is Nothing Then
    GPE Target
 ElseIf Not Intersect(Target, [S13].Resize(Rws + 9)) Is Nothing Then
    GPE Target                                                          '*'
 End If
End Sub

Sub GPE(Targ As Range)                                      '*'
    With Targ
        .Offset(, 1).Value = .Offset(, -1).Value * .Value
    End With
End Sub                                                     '*'

Mình cho code vào dữ liệu phí lưu kho chạy tốt bạn ah. Chỉ còn cột bốc xếp nhập xuất và vận chuyển là chưa cho kết quả thôi. Cám ơn Bạn nhiều nhé!

 

[Hoang2013]

Bạn đã chép thiếu cái này?

Sub GPE(Targ As Range)                                      '*'
    With Targ
        .Offset(, 1).Value = .Offset(, -1).Value * .Value
    End With
End Sub                                                     '*'

 

[ndhmoney686]

Bạn đã chép thiếu cái này?

Sub GPE(Targ As Range)                                      '*'
    With Targ
        .Offset(, 1).Value = .Offset(, -1).Value * .Value
    End With
End Sub                                                     '*'

Ok rồi bạn ah. Cám ơn Bạn rất nhiều!
ah, bạn ơi giả sử phần dữ liệu tự động tính đó. Một người nào đó xóa đi. Mình muốn đỡ bị sót. Thì có lệnh nào trước khi lấy dữ liệu bấm một phát nó chạy full luôn (để cập nhập lại toàn bộ kết quả)

 

[Hoang2013]

Bạn chép 2 macro này vô Module1

Option Explicit
Sub TTKetQua()
 Dim Rws As Long, Tmp As Double, DG As Double
 Dim Cls As Range
 
 Sheet1.Select
 Rws = [B13].End(xlDown).Row - 12
 For Each Cls In [I13].Resize(Rws)
    
    If Cls.Offset(, -1).Value > 0 Then
        Cls.Offset(, 1).Value = 0
    Else
        With Cls
            DG = .Value
            .Offset(, 1).Value = (.Offset(, -5).Value + .Offset(, -4).Value) * DG / 2
            .Offset(, 1).Value = (.Offset(, -5).Value + .Offset(, -4).Value) * DG / 2
            Tmp = (.Offset(, -6).Value + .Offset(, -5).Value) * DG
            If Tmp > 0 Then
                .Offset(, 2).Value = .Offset(, -6).Value * DG
            Else
                .Offset(, 2).Value = (.Offset(, -3).Value + .Offset(, -2).Value) * DG
            End If
        End With
    End If
    If Cells(Cls.Row, "M") > 0 Then GPE Cells(Cls.Row, "M")
    If Cells(Cls.Row, "P") > 0 Then GPE Cells(Cls.Row, "P")
    If Cells(Cls.Row, "s") > 0 Then GPE Cells(Cls.Row, "s")
 Next Cls
End Sub

Sub GPE(Targ As Range)                                      '*'
    With Targ
        .Offset(, 1).Value = .Offset(, -1).Value * .Value
    End With
End Sub                                                     '*'

Lưu í: Ta có thể bỏ macro GPE bên trang tính chứa dữ liệu đi

Khi đó macro sự kiện vẫn gọi được macro GPE ở module1 được.

 

[ndhmoney686]

Option Explicit
Sub TTKetQua()
 Dim Rws As Long, Tmp As Double, DG As Double
 Dim Cls As Range
 
 Sheet1.Select
 Rws = [B13].End(xlDown).Row - 12
 For Each Cls In [I13].Resize(Rws)
    
    If Cls.Offset(, -1).Value > 0 Then
        Cls.Offset(, 1).Value = 0
    Else
        With Cls
            DG = .Value
            .Offset(, 1).Value = (.Offset(, -5).Value + .Offset(, -4).Value) * DG / 2
            .Offset(, 1).Value = (.Offset(, -5).Value + .Offset(, -4).Value) * DG / 2
            Tmp = (.Offset(, -6).Value + .Offset(, -5).Value) * DG
            If Tmp > 0 Then
                .Offset(, 2).Value = .Offset(, -6).Value * DG
            Else
                .Offset(, 2).Value = (.Offset(, -3).Value + .Offset(, -2).Value) * DG
            End If
        End With
    End If
    If Cells(Cls.Row, "M") > 0 Then GPE Cells(Cls.Row, "M")
    If Cells(Cls.Row, "P") > 0 Then GPE Cells(Cls.Row, "P")
    If Cells(Cls.Row, "s") > 0 Then GPE Cells(Cls.Row, "s")
 Next Cls
End Sub

Sub GPE(Targ As Range)                                      '*'
    With Targ
        .Offset(, 1).Value = .Offset(, -1).Value * .Value
    End With
End Sub                                                     '*'

Lưu í: Ta có thể bỏ macro GPE bên trang tính chứa dữ liệu đi

Khi đó macro sự kiện vẫn gọi được macro GPE ở module1 được.

Tuyệt vời Bạn ơi. Đúng như mong đợi. Cám ơn Bạn nhiều!
Mình thích món code này nắm. Mấy lần đầu tư thời gian vào nghiên cứu và đi học 1 rồi. Nhưng mèo vẫn hoàn mèo. Về công thức thì nghiên cứu thấy Ok, còn món code sao khó thế