Nhờ mọi người chỉ dùm lỗi VBA này !

[vannam123]

Em muốn cột C nó tự tính như bên cột B mà sao chỉnh cái phép tính trong sheet code nó không chạy và nó báo lỗi ...save về *(.xlsx) không cho !
Cảm ơn mọi người !

Private Sub Worksheet_Change(ByVal Target As Range)
Dim expression0 As String, expression As String, result As Double
Dim Tmp, I As Long, Kq As Double
Dim fRow As Long, eRow As Long, C As Long
On Error Resume Next
If Target.Count > 1 Or Target.Column <> 2 Or Target.Value = "" Then Exit Sub
If Not Intersect(Target, Range("C6:C4000")) Is Nothing Then
I = Target.Row
If InStr(Target, "=") > 0 Then
expression0 = " " & Trim(Split(Target.Value, "=")(0))
Else
expression0 = " " & Trim(Target.Value)
End If
If InStr(expression0, ":") > 0 Then
expression = Trim(Split(expression0, ":")(1))
Else
expression = Trim(expression0)
End If
expression = Replace(expression, ",", ".")
Application.EnableEvents = False
On Error GoTo end_
result = Evaluate(expression)
Target.Value = expression0 & " = " & Format((result), "#,##0.000")
With Target.Characters(InStr(Target, "=") + 1).Font
.FontStyle = "Times New Roman"
.ColorIndex = 3
End With
Tmp = Split(Target.Value, "=")
Kq = Tmp(2)
If Kq Then
Target.Offset(, 5) = Kq
End If
'================================================================================================
D = Target.Offset(, 2).Column
eRow = Target.Offset(, -1).End(xlDown).Row: fRow = Target.Offset(, -1).End(xlUp).Row
If eRow = Rows.Count Then eRow = Target.Row + 1
If Target.Offset(, -1) = Empty Then
Cells(fRow, D + 4) = "=Sum(" & Replace(Range(Cells(fRow + 1, D + 4), Cells(eRow - 1, D + 4)).Address, "$", "") & ")"
End If
'================================================================================================
end_:
End If
Application.EnableEvents = True
End Sub

 

[befaint]

Cho khúc trên vào chỗ khoanh đỏ.

 

[vannam123]

Cho khúc trên vào chỗ khoanh đỏ.

View attachment 198173

không hiểu bạn ơi..chỉ dùm mình được không ?

 

[vannam123]

xin mọi người chỉ dùm chỗ sai..phép tính không thực hiện được bên cột C

Private Sub Worksheet_Change(ByVal Target As Range)
Dim expression0 As String, expression As String, result As Double
Dim Tmp, I As Long, Kq As Double
Dim fRow As Long, eRow As Long, C As Long
On Error Resume Next
If Target.Count > 1 Or Target.Column <> 2 Or Target.Value = "" Then Exit Sub
If Not Intersect(Target, Range("C6:C4000")) Is Nothing Then
I = Target.Row
If InStr(Target, "=") > 0 Then
expression0 = " " & Trim(Split(Target.Value, "=")(0))
Else
expression0 = " " & Trim(Target.Value)
End If
If InStr(expression0, ":") > 0 Then
expression = Trim(Split(expression0, ":")(1))
Else
expression = Trim(expression0)
End If
expression = Replace(expression, ",", ".")
Application.EnableEvents = False
On Error GoTo end_
result = Evaluate(expression)
Target.Value = expression0 & " = " & Format((result), "#,##0.000")
With Target.Characters(InStr(Target, "=") + 1).Font
.FontStyle = "Times New Roman"
.ColorIndex = 3
End With
Tmp = Split(Target.Value, "=")
Kq = Tmp(2)
If Kq Then
Target.Offset(, 5) = Kq
End If
'================================================================================================
D = Target.Offset(, 2).Column
eRow = Target.Offset(, -1).End(xlDown).Row: fRow = Target.Offset(, -1).End(xlUp).Row
If eRow = Rows.Count Then eRow = Target.Row + 1
If Target.Offset(, -1) = Empty Then
Cells(fRow, D + 4) = "=Sum(" & Replace(Range(Cells(fRow + 1, D + 4), Cells(eRow - 1, D + 4)).Address, "$", "") & ")"
End If
'================================================================================================
end_:
End If
Application.EnableEvents = True
End Sub

 

[VetMini]

Sau dòng thứ 5, On Error Resume Next
Thêm vào dòng này:
msgbox "Dieu kien la so o <= 1; so cot = 2; Tri thay doi = trong" & vbNewLine & _
"Thuc te la: so o = " & Target.Count & "; so cot = " & Target.Column & "; Tri thay doi = " & IIf(Target.Value<>"", Target.Value, "trong")