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

limfx · 8/3/21

Em muốn gắn công thức vào ô B4:B23 (đã có text) khi D4

23 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

Nhattanktnn · 8/3/21

limfx đã viết:
Em muốn gắn công thức vào ô B4:B23 (đã có text) khi D423 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

409 · 8/3/21

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.

limfx · 8/3/21

409 đã viết:
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

409 · 8/3/21

limfx đã viết:
Bác gắn với text trong cột B đã có trước giúp

Việc gắn text đã có sẽ làm text đó dài dần mỗi lần công thức ở cột D thay đổi.
Hoặc phải sử dụng cột phụ nhập dữ liệu "Text đã có" mà bạn muốn.
Bạn chọn gì?

limfx · 8/3/21

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!

Nhattanktnn · 8/3/21

Bỏ thời gian viết code cho bạn mà bạn không phản hồi gì hết thế nhỉ?

409 · 8/3/21

Nhattanktnn đã viết:
If Cll.HasFormula Then

Dùng cái này để kiểm tra cell có công thức hay không mới chuẩn nè. Code hay hơn nhau ở chỗ này đấy.

limfx · 9/3/21

Nhattanktnn đã viết:

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?

Nhattanktnn · 10/3/21

limfx đã viết:
Cảm ơn Bác, code bác viết em đưa vào không chạy được?

Không chạy được cụ thể là bị như thế nào? Hay bạn lại lầm tưởng giống "worksheet_Change" cứ nhấn vào đâu đó trên cột "D" là chạy code?

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

limfx

Thành viên mới

File đính kèm

Nhattanktnn

Thành viên gắn bó

409

Thành viên mới

limfx

Thành viên mới

409

Thành viên mới

limfx

Thành viên mới

Nhattanktnn

Thành viên gắn bó

409

Thành viên mới

limfx

Thành viên mới

Nhattanktnn

Thành viên gắn bó

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng