Cách xoá toàn bộ làm tròn (Round, Roundup, Rounddown...)

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài

Decepticon

Thành viên chính thức
Tham gia
25/4/16
Bài viết
81
Được thích
13
Như tít , các bác có cách nào xoá toàn bộ làm tròn kể cả round nằm giữa công thức không ạ, hàm round ngay sau dấu = thì dễ chứ nằm giữa công thức thì khó xử lý quá ><
 
1724246967098.png



làm như hình là được, sao đó thay thế (ctrol+H)round bằng modfun.round, sau này muốn khôi phục lại thì xóa cái đầu "modfun."
hoặc viết hàm mới ROUNDVBA, và thay thế hàm round trong excel bằng roundVBA.
 
Upvote 0
...
làm như hình là được, sao đó thay thế (ctrol+H)round bằng modfun.round, sau này muốn khôi phục lại thì xóa cái đầu "modfun."
hoặc viết hàm mới ROUNDVBA, và thay thế hàm round trong excel bằng roundVBA.
Nếu phải làm kiểu này thì dùng names và lambda khỏe hơn. Khỏi phải sử dụng cái đuôi xlsm.

1724264012335.png

1724264220606.png
 
Upvote 0
Thêm phiên bản nữa để mã được hoàn thiện, mã này thêm chức năng chọn đúng vị trí thứ tự của một Hàm mới thực hiện xóa.

Ví dụ với biểu thức có các hàm IF lòng nhau:
=IF(IF(IF(A1>A2,A3,A4)>A5,A6,A7)>A8,IF(A9>A10,A11,A12),IF(A13>A14,A15,A16))+IF(A17>A18,A19,A20)

Và muốn xóa vị trí 3, giữ lại đối số thứ 2, thì FXs sẽ là:

Và muốn xóa vị trí 3, 5 và 6, giữ lại đối số thứ 2, thì FXs sẽ là:
FXs = Array("IF", [{3,5,6}], 2)

Và muốn xóa các hàm khác, hãy nhập theo sau tương ứng, thì FXs sẽ là:
FXs = Array("IF", [{3,5,6}], 2, "ROUND", [{1,3}], 1, "IFERROR", [{4,6}], 1)

***Lưu ý: đối số floor của phương thức EditorFXInFXs, là số khả năng cặp ngoặc tròn lồng nhau, nếu biểu thức có nhiều cặp ngoặc tròn, hãy tăng floor lên.

Mã ví dụ:
JavaScript:
Sub EditorFXInFXs_test()
  Dim s$, FXs
  s = "=IF(IF(IF(A1>A2,A3,A4)>A5,A6,A7)>A8,IF(A9>A10,A11,A12),IF(A13>A14,A15,A16))+IF(A17>A18,A19,A20)"
  FXs = Array("IF", [{3,5,6}], 2)
  Debug.Print EditorFXInFXs(s, FXs)
End Sub

(Tôi sẽ sớm tạo bài viết mới để chia sẻ chủ đề rộng hơn, gồm chèn hàm, thay thế hàm)

Toàn bộ mã:
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'


Private Const projectClassName = "EditorFormulas"
Private Const projectClassVersion = "1.03"
Option Compare Text
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Sub RemoveFXs_test()
  Dim file$, dest$, FXs, sheets, ix%
  ' Vi tri
  FXs = Array("ROUND", 1, 1, "ROUNDUP", 1, 1, "ROUNDDOWN", 1, 1)
  ' Hoac mang
  FXs = Array("ROUND", [{1,3,5}], 1, "ROUNDUP", [{1,3,5}], 1, "ROUNDDOWN", [{1,3,5}], 1)
  '
  sheets = Array("Sheet1", "Sheet2", "Sheet3")
  file = ThisWorkbook.Path & "\Test huy ROUND.xlsm"
  dest = ""
  MsgBox IIf(RemoveFXs(FXs, sheets, file, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub

Private Sub EditorFXInFXs_test2()
  On Error Resume Next
  Dim t!: t = timer
  Dim s, rg0, rg, Cell, r0&, c0&, r&, c&, a As Range, b As Boolean, y As Boolean, f$, arr, FXs

  ' Vi tri
  FXs = Array("ROUND", 1, 1, "ROUNDUP", 1, 1, "ROUNDDOWN", 1, 1)
  ' Hoac mang
  FXs = Array("ROUND", [{1,3,5}], 1, "ROUNDUP", [{1,3,5}], 1, "ROUNDDOWN", [{1,3,5}], 1)
  '
 
  Set rg0 = ActiveSheet.UsedRange
  Set rg = rg0.SpecialCells(-4123)
  If rg Is Nothing Then Exit Sub
  y = rg(1, 1).Formula2 <> ""
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  arr = rg0.Formula: r0 = rg0.Row - 1: c0 = rg0.column - 1
  For Each Cell In rg
    r = Cell.Row - r0: c = Cell.column - r0
    arr(r, c) = EditorFXInFXs(arr(r, c), FXs)
  Next
  With rg0
    If y Then .Formula2 = arr Else .Formula = arr
  End With

  Application.Calculation = xlCalculationAutomatic
  ActiveSheet.Calculate  
  Debug.Print timer - t
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Private Function RemoveFXs(FXs, sheets, filename$, Optional ByVal destDirectories$, Optional overwrite As Boolean = True) As Boolean
  On Error Resume Next
  Dim file$, file2$, ix%, ex$
  Dim s$, re As Object, oFile As Object, oFile2 As Object, oFolder As Object, b As Boolean, y As Boolean
  Dim oSh, ms, ms2, FSO As Object, tPath, tPath2, fn$, p1$, p2$, p3$, sp$, sh
  Dim it, m, FileName_Path, ZipFile, k&, extFile, ext$, fl%, shfXML$, xl_type&
  Set re = glbRegex
  Set FSO = glbFSO
  Set oSh = glbShellA
  '-----------------------------------------------
  file = filename
  Select Case True
  Case file Like "*.xla": xl_type = 18: ext = ".xla": b = True
  Case file Like "*.xlsb": xl_type = 50: ext = ".xlsb": b = True
  Case file Like "*.xlsx": xl_type = 51: ext = ".xlsx"
  Case file Like "*.xlsm": xl_type = 52: ext = ".xlsm"
  Case file Like "*.xlam": xl_type = 55: ext = ".xlam"
  Case file Like "*.xls": xl_type = 56: ext = ".xls": b = True
  Case Else: Exit Function
  End Select
  If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
  With FSO
    Set oFile = .GetFile(file)
    If oFile Is Nothing Then Exit Function
    fn = oFile.Name
    If b Then fn = Replace(fn, ext, ".xlsm", , , 1): ext = ".xlsm"
    If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\": fn = "(RemoveFxs) " & fn
 
    CreateFolder destDirectories, FSO
    ZipFile = destDirectories & fn & ".zip"
    file2 = destDirectories & fn

    If overwrite Then .GetFile(file2).Delete
    If b Then
      With CreateObject("Excel.Application")
        .EnableEvents = False
        .DisplayAlerts = False
        With .Workbooks.Open(filename:=file, UpdateLinks:=False, ReadOnly:=True)
          .SaveAs ZipFile, 51: .Close False
        End With
        .Quit
      End With
    Else
      .copyFile file, ZipFile, True
    End If
    tPath = Environ$("temp") & "\VBE\CopyAndModify\"
    CreateFolder tPath & "worksheets\", FSO
 
    err.Clear: DoEvents:
    oSh.Namespace(CVar(tPath & "worksheets\")).movehere oSh.Namespace(CVar(ZipFile & "\xl\worksheets\")).items, 4 Or 16

    re.Pattern = "<f>(.+?)</f>"
    Set oFolder = .GetFolder(tPath & "worksheets\")
    For Each oFile2 In oFolder.Files
      DoEvents: y = False
      With .OpenTextFile(oFile2.Path, 1, True, -2): s = .ReadAll(): Call .Close: End With
      If IsArray(sheets) Then
        For Each sh In sheets
          If InStr(1, s, " codeName=""" & sh & """", 1) Then y = True
        Next
      Else
        y = True
      End If
      If y Then
        s = EditorFXsInFile(s, FXs, re)
        With .OpenTextFile(oFile2.Path, 2, True, -2): Call .Write(s): Call .Close: End With
      End If
    Next
    err.Clear
    Dim ccc&: ccc = oSh.Namespace(CVar(tPath & "worksheets\")).items.Count
    oSh.Namespace(CVar(ZipFile & "\xl")).copyhere oSh.Namespace(CVar(tPath & "worksheets\")), 4 Or 16
    k = 0
    Do While oSh.Namespace(ZipFile & "\xl\worksheets\") Is Nothing
      DoEvents: Sleep 20
      k = k + 1: If k > 20 Then Exit Do
    Loop: k = 0
    Do While oSh.Namespace(ZipFile & "\xl\worksheets\").items.Count = ccc
      DoEvents: Sleep 20
      k = k + 1: If k > 20 Then Exit Do
    Loop
    err.Clear
    DoEvents: Sleep 200
    .MoveFile ZipFile, file2
    RemoveFXs = err = 0
    .GetFolder(tPath).Delete
  End With
E:

End Function
Sub removeAndDeleteFormulas()
  Dim s$, FXs, re As Object
  FXs = Array("ROUND", 1, 1, "ROUNDDOWN", 1, 1)
  s = "a<f>=@ROUND(1,2)</f>b<f>=@ROUNDDOWN(1,2)</f>c"
Set re = glbRegex
  Debug.Print EditorFXsInFile(s, FXs, re)
End Sub


Private Function EditorFXsInFile(ByVal xml$, FXs, Optional ByVal RegExp As Object) As String
  Dim t$, s$, ms, m, f&, l&, fl&, z$
  With RegExp
    Set ms = .Execute(xml):
    For Each m In ms
      s = m.submatches(0): f = m.FirstIndex: l = m.Length
      If z = "" Then
        If f > 0 Then z = Left$(xml, f)
      Else
        If f >= fl Then z = z & Mid$(xml, fl, f - fl + 1)
      End If
      z = z & "<f>" & EditorFXInFXs(s, FXs, True) & "</f>"
      fl = f + l + 1
    Next m
    z = z & Mid$(xml, fl)
  End With
  EditorFXsInFile = z
End Function
Function EditorFXInFXs(ByVal expression$, FXs, Optional byFile As Boolean, Optional floor% = 10) As String
  'Version 1.02
  Static re As Object, p4$, p5$, sp$, fl%
  Dim s$, pp, p1$, p2$, numberParam%, keepParam%, i%, j%, n%, m%, k%, cl, b As Boolean, z$
  Set cl = CreateObject("Scripting.Dictionary"): cl.CompareMode = 1
  If re Is Nothing Or floor <> fl Then
    Dim t$, p$, p3$, ms
    Set re = glbRegex()
    s = expression
    With Application
      sp = IIf(IIf(.UseSystemSeparators, .International(3), .DecimalSeparator) = ".", ",", ";")
    End With
    p = "(?:""(?:""""|[^""])*""|[^\(\)\{\}\[\]'])"
    p1 = "(?:""(?:""""|[^""])*""|[^\(\)\{\}\[\]'" & sp & "])"
    p2 = "(?:'(?:''|'""|'\[|'\]|[^'])+')"
    p3 = "\{" & p & "+\}"
    p2 = "(?:" & p2 & "|" & p3 & "|" & p1 & ")"
    p4 = p2
    For i = 1 To 3: p4 = "(?:\[" & Replace(p4, p1, p) & "+\]|" & p2 & ")": Next
    p5 = p4 & "*"
 
    For i = 1 To floor: p5 = "(?:\(" & Replace(p5, p1, p) & "\)|" & p4 & ")*": Next
    p1 = "": p2 = ""
    floor = fl
  End If
  For m = LBound(FXs) To UBound(FXs) Step 3
    If FXs(m) <> Empty Then
      p1 = "": j = FXs(m + 2): z = "": b = j = 0
      If IsArray(FXs(m + 1)) Then
        s = " " & Join(FXs(m + 1), " ") & " ":  p2 = "(?:" & FXs(m) & ")":  GoSub r: RecursionRemoveFXInFXs expression, re, s, z: expression = z
      Else
        s = FXs(m + 1)
        If s <= 0 Then
          p1 = "0_" & j
          If cl.Exists(p1) Then cl(p1) = cl(p1) & "|" & FXs(m) Else cl(p1) = FXs(m)
        Else
          s = " " & s & " ":  p2 = "(?:" & FXs(m) & ")": GoSub r: RecursionRemoveFXInFXs expression, re, s, z: expression = z
        End If
      End If
    End If
  Next
  With re
    For Each pp In cl.keys()
      s = "": p1 = "": p2 = "(?:" & cl(pp) & ")": j = CInt(Split(pp, "_")(1)): b = j = 0: GoSub r
      While .test(expression): expression = .Replace(expression, IIf(b, "", "$1$4")): Wend
    Next
    If Not byFile Then
      .Pattern = "(?:- *- *)+((?:- *){1,2})"
      While .test(expression): expression = .Replace(expression, "$1"): Wend
    End If
  End With
  Set cl = Nothing
  EditorFXInFXs = expression
Exit Function
r:
  For i = 1 To j
    If i = j Then
      p1 = p1 & IIf(i = 1, "", sp) & IIf(b, "", ")") & "(" & p5 & ")"
    Else
      p1 = p1 & "(?:" & IIf(p1 = "" Or i = 1, "", sp) & p5 & ")"
    End If
  Next
  If b Then
    p1 = p1 & "(?:" & p5 & ")(?:" & sp & p5 & ")*"
  Else
    p1 = "(" & p1 & "((?:" & sp & p5 & ")*)"
  End If
  If byFile Then
    '> (?:&gt;)  < (?:&lt;)   & (?:&amp;)
    If b Then
      p1 = "(?:(?:&gt;=|&lt;=|&lt;&gt;|&amp;|&gt;|&lt;|[\+\*\/\=^" & sp & " -]*|^)(?:@?" & p2 & ")\(" & p1 & "\))"
    Else
      p1 = "([\*\+\/\(=\^\" & sp & "- ]|&amp;|&gt;|&lt;|^)(@?" & p2 & "\()" & p1 & "\)"
    End If
  Else
    If b Then
      p1 = "(?:(?:>=|<=|<>|[\+\*&\/\\=<>^ " & sp & "-]*|^)(?:@?" & p2 & ")\(" & p1 & "\))"
    Else
      p1 = "([\*\+\/\(&\^\=<> " & sp & "-]|^)(@?" & p2 & "\()" & p1 & "\)"
    End If
  End If
  re.Pattern = p1
Return
End Function

Private Sub RecursionRemoveFXInFXs(ByVal text$, ByVal RegExp As Object, indexs$, Optional z$, Optional x%)
  Dim t1$, t2$, t3$, s$, s1$, s2$, s3$, s4$, s0$, ms, m, o, f&, l&, fl&, x2%, b As Boolean
  With RegExp
    Set ms = .Execute(text):
    For Each m In ms
      s = m: x = x + 1: x2 = x: f = m.FirstIndex: l = m.Length: b = InStr(indexs, " " & x2 & " ") > 0
      If z = "" Then
        If f > 0 Then z = Left$(text, f)
      Else
        If f >= fl Then z = z & Mid$(text, fl, f - fl + 1)
      End If
      Set o = m.submatches: s0 = o(0): s1 = o(1): s2 = o(2): s3 = o(3): s4 = o(4)
      If .test(s2) Then t1 = "": RecursionRemoveFXInFXs s2, RegExp, indexs, t1, x Else t1 = s2
      If .test(s3) Then t2 = "": RecursionRemoveFXInFXs s3, RegExp, indexs, t2, x Else t2 = s3
      If .test(s4) Then t3 = "": RecursionRemoveFXInFXs s4, RegExp, indexs, t3, x Else t3 = s4
      If b Then z = z & s0 & t2 Else z = z & s0 & s1 & t1 & t2 & t3 & ")"
      fl = f + l + 1
    Next m
  End With
  If ms.Count Then z = z & Mid$(text, fl) Else z = text
End Sub


Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  If FileSystem Is Nothing Then Set FileSystem = glbFSO
  On Error GoTo Ends
  FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      tmp = tmp & FolderArray(i) & "\"
      If Not .FolderExists(tmp) Then DoEvents: .CreateFolder (tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function
Private Function glbRegex(Optional bglobal = True, Optional IgnoreCase = True, Optional MultiLine = True) As Object
  Set glbRegex = CreateObject("VBScript.RegExp")
  With glbRegex: .Global = bglobal: .IgnoreCase = IgnoreCase: .MultiLine = MultiLine: End With
End Function
Private Function glbFSO() As Object
  Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Private Function glbShellA() As Object
  Set glbShellA = CreateObject("Shell.Application")
End Function
Private Function StandardPath(ByVal Path As String) As String
    StandardPath = Path & IIf(Right(Path, 1) <> "\", "\", "")
End Function
Private Function ThisPath(Optional ByVal filename As String) As String
    ThisPath = ThisWorkbook.Path & "\" & filename
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Theo nguyên tắc text trong formula không được động tới, chỉ xử lý function của formula.

Thế này thì khóc tiếng mán hết. Nói chung cần có kinh nghiệm thực tế về formula và não cần phải hoạt động thêm nữa. :p

1724316653932.png
 
Upvote 0
Cháu thấy ổn đó bác, cháu đanng nghĩ cách dùng lambda mà dùng trực tiếp round.
VBA chấp nhận cho chồng tên, Các biến và hằng khai báo trong module sẽ che đi các biến và hằng có sẵn trong VBA. Các hàm đặt trùng tên cũng vậy. VBA măc định không gian ngữ cảnh là Module.
Ví dụ bạn đặt một hàm tên là MID thì:
- Nếu private thì tất cả MID's trong module đều chỉ về hàm này hàm MID của VBA bị che.
- Nếu public thì tất cả MID's trong project đều chỉ về hàm này.

Excel đặt ưu tiên cho hàm bảng tính chi nên names không thể che hàm bảng tính.
 
Upvote 0
Web KT

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

Back
Top Bottom