Tự động gắn hàm diễn giải công thức vào Text ô kế bên;

Liên hệ QC

limfx

Thành viên mới
Tham gia
20/2/09
Bài viết
34
Được thích
1
Em muốn gắn công thức vào ô B4:B23 (đã có text) khi D4:D23 xuất hiện công thức tính (không xuất hiện công thức thì không thực hiện). Tận dụng hàm diễn giải () phía dưới Nhờ các bác giúp đỡ! Thanks!
Option Explicit
Public Function Diengiai(rngData As Range)
On Error Resume Next
Dim strText As String, strText2 As String
Dim i As Long, j As Long
Dim k
Dim subText() As String, dau() As String

strText = rngData.Formula

For i = 1 To Len(strText)
Select Case Mid(strText, i, 1)
Case "+", "-", "*", "/", "^", "(", ")"
ReDim Preserve dau(j)
dau(j) = Mid(strText, i, 1)
j = j + 1
End Select
Next i

strText = Trim$(Replace(strText, "=", ""))
strText = Replace(strText, "+", "@")
strText = Replace(strText, "-", "@")
strText = Replace(strText, "*", "@")
strText = Replace(strText, "/", "@")
strText = Replace(strText, "\", "@")
strText = Replace(strText, "^", "@")
strText = Replace(strText, "(", "@")
strText = Replace(strText, ")", "@")

subText = Split(strText, "@")

For i = 0 To UBound(subText)
If Not IsNumeric(subText(i)) Then
Err.Clear
k = Range(subText(i))

If Err.Number = 0 Then
If IsEmpty(Range(subText(i))) Then subText(i) = 0
If Range(subText(i)).NumberFormat <> "General" Then
subText(i) = Format$(Range(subText(i)).Value, Range(subText(i)).NumberFormat)
ElseIf Range(subText(i)).NumberFormat = "General" Then
subText(i) = Range(subText(i)).Value
End If
Else
subText(i) = subText(i)
End If
If Left(subText(i), 1) = "-" Then subText(i) = "(" & subText(i) & ")"
End If
Next i

ReDim Preserve dau(UBound(subText))

For i = 0 To UBound(subText)
strText2 = strText2 & subText(i) & dau(i)
Next i

Diengiai = strText2 & " ="
End Function

hamdiengiai.jpg
 

File đính kèm

  • gan chiet tinh 2.xlsm
    15.8 KB · Đọc: 7
Em muốn gắn công thức vào ô B4:B23 (đã có text) khi D4:D23 xuất hiện công thức tính (không xuất hiện công thức thì không thực hiện). Tận dụng hàm diễn giải () phía dưới Nhờ các bác giúp đỡ! Thanks!
Option Explicit
Public Function Diengiai(rngData As Range)
On Error Resume Next
Dim strText As String, strText2 As String
Dim i As Long, j As Long
Dim k
Dim subText() As String, dau() As String

strText = rngData.Formula

For i = 1 To Len(strText)
Select Case Mid(strText, i, 1)
Case "+", "-", "*", "/", "^", "(", ")"
ReDim Preserve dau(j)
dau(j) = Mid(strText, i, 1)
j = j + 1
End Select
Next i

strText = Trim$(Replace(strText, "=", ""))
strText = Replace(strText, "+", "@")
strText = Replace(strText, "-", "@")
strText = Replace(strText, "*", "@")
strText = Replace(strText, "/", "@")
strText = Replace(strText, "\", "@")
strText = Replace(strText, "^", "@")
strText = Replace(strText, "(", "@")
strText = Replace(strText, ")", "@")

subText = Split(strText, "@")

For i = 0 To UBound(subText)
If Not IsNumeric(subText(i)) Then
Err.Clear
k = Range(subText(i))

If Err.Number = 0 Then
If IsEmpty(Range(subText(i))) Then subText(i) = 0
If Range(subText(i)).NumberFormat <> "General" Then
subText(i) = Format$(Range(subText(i)).Value, Range(subText(i)).NumberFormat)
ElseIf Range(subText(i)).NumberFormat = "General" Then
subText(i) = Range(subText(i)).Value
End If
Else
subText(i) = subText(i)
End If
If Left(subText(i), 1) = "-" Then subText(i) = "(" & subText(i) & ")"
End If
Next i

ReDim Preserve dau(UBound(subText))

For i = 0 To UBound(subText)
strText2 = strText2 & subText(i) & dau(i)
Next i

Diengiai = strText2 & " ="
End Function

View attachment 255105
Thử thế này xem:
Mã:
Option Explicit
Sub abc()
Dim Cll As Range, Rng As Range, MSG As String
Static I As Long
With Sheets("Sheet1")
Set Rng = .Range("D4:D" & .Cells(Rows.Count, "D").End(xlUp).Row)
If I > 0 Then
    MSG = MsgBox("Da chay code " & I & " lan" & vbCrLf & "Ban co muon thuc hien lai?", vbYesNo + vbQuestion)
    If MSG = vbNo Then Exit Sub
End If
I = I + 1
For Each Cll In Rng
    If Cll.HasFormula Then
        Cll.Offset(, -2) = Cll.Offset(, -2) & Replace(Cll.Formula, "=", " :")
    End If
Next
End With
End Sub
 
Upvote 0
Mình không dùng function Diengiai của bạn ở trên, nhưng theo ý mình hiểu thì bạn thử code sau có đúng ý bạn cần không nhé:
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D4:D23")) Is Nothing Then
        Range("B" & Target.Row).Value = ""
        If Range("D" & Target.Row).Text <> Range("D" & Target.Row).Formula Then
            Range("B" & Target.Row).Value = "'" & Range("D" & Target.Row).Formula
        End If
    End If
End Sub

Đặt code trong Sheet bạn cần.
 
Upvote 0
Mình không dùng function Diengiai của bạn ở trên, nhưng theo ý mình hiểu thì bạn thử code sau có đúng ý bạn cần không nhé:
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D4:D23")) Is Nothing Then
        Range("B" & Target.Row).Value = ""
        If Range("D" & Target.Row).Text <> Range("D" & Target.Row).Formula Then
            Range("B" & Target.Row).Value = "'" & Range("D" & Target.Row).Formula
        End If
    End If
End Sub

Đặt code trong Sheet bạn cần.
Bác gắn với text trong cột B đã có trước giúp
 
Upvote 0
Phương án sử dụng cột phụ nhập dữ liệu "Text đã có" hợp lý hơn. Thanks bác 409 nhiều!
 
  • Thích
Reactions: 409
Upvote 0
Bỏ thời gian viết code cho bạn mà bạn không phản hồi gì hết thế nhỉ?
 
Upvote 0
Thử thế này xem:
Mã:
Option Explicit
Sub abc()
Dim Cll As Range, Rng As Range, MSG As String
Static I As Long
With Sheets("Sheet1")
Set Rng = .Range("D4:D" & .Cells(Rows.Count, "D").End(xlUp).Row)
If I > 0 Then
    MSG = MsgBox("Da chay code " & I & " lan" & vbCrLf & "Ban co muon thuc hien lai?", vbYesNo + vbQuestion)
    If MSG = vbNo Then Exit Sub
End If
I = I + 1
For Each Cll In Rng
    If Cll.HasFormula Then
        Cll.Offset(, -2) = Cll.Offset(, -2) & Replace(Cll.Formula, "=", " :")
    End If
Next
End With
End Sub
Cảm ơn Bác, code bác viết em đưa vào không chạy được?
 
Upvote 0
Web KT
Back
Top Bottom