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á ><Gửi bạn 2 đoạn code để test. Việc hoàn thiện sẽ xử lý sauTất cả các ô bác ạ, lý tưởng là Ctrl+A hoặc chọn vùng selection, chạy script là toàn bộ hàm làm tròn bay hết luôn
Trong file đính kèm có macro của bác hieudoanxd cũng khá hoàn thiện rồi, mấy ô công thức đơn giản bị lỗi nhưng phức tạp hnó lại xử lý đc
Option Explicit
Sub B_locCongthuc()
Dim Nguon As Range
Dim tmp As Range
Dim Kq
Dim rws, cls
Dim Z As Long
Dim i, j, k
With Sheet1
Set Nguon = .UsedRange
End With
rws = Nguon.Rows.Count
cls = Nguon.Columns.Count
ReDim Kq(1 To rws * cls, 1 To 1)
Z = 1
For Each tmp In Nguon.SpecialCells(xlCellTypeFormulas)
Kq(Z, 1) = Replace(tmp.Formula, "=", "")
Z = Z + 1
Next tmp
With Sheet2
.UsedRange.Clear
.Range("A6").Resize(Z, 1) = Kq
End With
End SubOption Explicit
Sub A_LoaiTru_()
Dim Nguon
Dim Tam
Dim Thongke
Dim Ketqua
Dim dau, cuoi
Dim slT, slP
Dim trs, congSL, maxGT
Dim rws, cls
Dim Z As Long
Dim i, j, k, x, t
Nguon = Sheet2.Range("A6").CurrentRegion
rws = UBound(Nguon)
cls = UBound(Nguon, 2)
ReDim Thongke(1 To rws, 1 To 100)
ReDim Ketqua(1 To rws, 1 To 1)
Dim Reg As New RegExp
Reg.Pattern = "ROUND" & "[^\(]*\("
Reg.Global = True
Z = 1
For i = 1 To rws
If Reg.Test(Nguon(i, 1)) Then
Thongke(i, 1) = Reg.Execute(Nguon(i, 1)).Count
For j = 0 To Reg.Execute(Nguon(i, 1)).Count - 1
Thongke(i, j + 2) = Reg.Execute(Nguon(i, 1))(j).FirstIndex
Next j
End If
If maxGT < Len(Nguon(i, 1)) Then maxGT = Len(Nguon(i, 1))
Next i
ReDim Tam(maxGT)
For i = 1 To rws
Ketqua(i, 1) = Nguon(i, 1)
If Thongke(i, 1) >= 1 Then
Tam(0) = 0
For t = 2 To Thongke(i, 1) + 1
k = Thongke(i, t) + 1
For j = k To Len(Nguon(i, 1))
If Mid(Nguon(i, 1), j, 1) = "(" Then
Tam(0) = Tam(0) + 1
Z = Tam(0)
Tam(Z) = k * 1000000 + j
dau = j + 1
Exit For
End If
Next j
slT = 1
slP = 0
Do While slT <> slP
dau = dau + 1
If Mid(Nguon(i, 1), dau, 1) = "(" Then slT = slT + 1
If Mid(Nguon(i, 1), dau, 1) = ")" Then slP = slP + 1
Loop
For j = dau To 1 Step -1
If Mid(Nguon(i, 1), j, 1) = "," Then
Tam(0) = Tam(0) + 1
Z = Tam(0)
Tam(Z) = j * 1000000 + dau
Exit For
End If
Next j
Next t
For j = 1 To Tam(0)
dau = Tam(j) \ 1000000
cuoi = Tam(j) Mod 1000000
k = Space(cuoi - dau + 1)
Mid(Ketqua(i, 1), dau, cuoi - dau + 1) = k
Next j
Ketqua(i, 1) = Application.Trim(Ketqua(i, 1))
End If
Next i
With Sheet3
.UsedRange.Clear
.Range("A6").Resize(UBound(Ketqua), UBound(Ketqua, 2)) = Ketqua
.UsedRange.Columns.AutoFit
End With
End Sub
Phở rất ngon.
Bác thử thêm món bún này nhé!mấy ô công thức đơn giản bị lỗi nhưng phức tạp hnó lại xử lý đc
Public Enum StyleRound
sNormal = 5
sUp = 7
sDown = 9
End Enum
Sub RemoveRound(rng As Range, Optional ByVal mStyle As StyleRound = 5)
Dim mFind As Long, mCount As Long, mFormula As Long
Dim str As String, sStyle As String, strL As String, strR As String
str = rng.Formula
Select Case mStyle
Case sNormal: sStyle = "ROUND("
Case sUp: sStyle = "ROUNDUP("
Case sDown: sStyle = "ROUNDDOWN("
End Select
'///////////////////////////////////////////////////////////////////////////
'Xoa Round
Do
mFind = InStr(1, str, sStyle) 'Xac dinh vi tri "ROUND"
If mFind = 0 Then Exit Do
i = mFind + mStyle 'Vi tri "("
Do
If Mid(str, i, 1) = "(" Then
mCount = mCount + 1
ElseIf Mid(str, i, 1) = ")" Then
mCount = mCount - 1
End If
i = i + 1
Loop Until mCount = 0
If i > Len(str) Then i = i - 1 'Truong hop ham ROUND o cuoi cong thuc
strL = Left(str, InStrRev(str, ",", i - 1) - 1)
strR = IIf(i = Len(str), "", Right(str, Len(str) - (i - 1)))
str = strL & strR
'Bo Ham Round
strL = Left(str, mFind - 1)
strR = Right(str, Len(str) - (mFind + mStyle))
str = strL & strR
Loop Until mFind = 0
If Application.DecimalSeparator = "," Then str = Replace(str, ".", ",")
rng.Formula = str
End Sub
Sub Test()
Dim rng As Range, str As String
For Each rng In Selection
str = rng.Formula
If InStr(1, str, "ROUND(") > 0 Then RemoveRound rng, sNormal
If InStr(1, str, "ROUNDUP(") > 0 Then RemoveRound rng, sUp
If InStr(1, str, "ROUNDDOWN(") > 0 Then RemoveRound rng, sDown
Next rng
End Sub
www.giaiphapexcel.com
-=ROUNDDOWN(SUBTOTAL(9;E2:E3);-1)-ROUND(E4+E5;-3)-ROUNDUP(E6-E7;)
Sub XoaRound()
Dim cell As Range
Dim text As String
Dim i As Long
Dim j As Long
Dim openParenStack As Collection
Dim closeParenStack As Collection
Dim targetRange As Range
Dim openPos As Long
Dim inTextRangeStart As Long
Dim ws As Worksheet
Set ws = ActiveSheet
If Selection.Address = ws.Cells.Address Then
Set targetRange = ws.UsedRange
ElseIf Selection.Rows.Count = ws.Rows.Count Or Selection.Columns.Count = ws.Columns.Count Then
Set targetRange = Intersect(ws.UsedRange, Selection)
Else
Set targetRange = Selection
End If
targetRange.Replace What:="=", Replacement:="#=", LookAt:=xlPart
targetRange.Replace What:="ROUND(", Replacement:="@(", LookAt:=xlPart
targetRange.Replace What:="ROUNDDOWN(", Replacement:="@(", LookAt:=xlPart
targetRange.Replace What:="ROUNDUP(", Replacement:="@(", LookAt:=xlPart
For Each cell In targetRange
text = cell.text
If InStr(text, "-@(") > 0 Then
Set openParenStack = New Collection
Set closeParenStack = New Collection
For i = 1 To Len(text)
Select Case Mid(text, i, 1)
Case "("
openParenStack.Add i
Case ")"
If openParenStack.Count > 0 Then
openPos = openParenStack.Item(openParenStack.Count)
If Mid(text, openPos - 2, 2) = "-@" Then
closeParenStack.Add i
End If
openParenStack.Remove openParenStack.Count
End If
End Select
Next i
If closeParenStack.Count > 0 Then
For i = closeParenStack.Count To 1 Step -1
j = closeParenStack.Item(i)
inTextRangeStart = InStrRev(Left(text, j), ",")
If inTextRangeStart > 0 Then
text = Left(text, inTextRangeStart - 1) & Mid(text, j)
End If
Next i
End If
cell.Value = text
End If
Next cell
targetRange.Replace What:="-@(", Replacement:="-(", LookAt:=xlPart
For Each cell In targetRange
text = cell.text
If InStr(text, "@(") > 0 Then
Set openParenStack = New Collection
Set closeParenStack = New Collection
For i = 1 To Len(text)
Select Case Mid(text, i, 1)
Case "("
openParenStack.Add i
Case ")"
If openParenStack.Count > 0 Then
openPos = openParenStack.Item(openParenStack.Count)
If Mid(text, openPos - 1, 1) = "@" Then
closeParenStack.Add i
End If
openParenStack.Remove openParenStack.Count
End If
End Select
Next i
If closeParenStack.Count > 0 Then
For i = closeParenStack.Count To 1 Step -1
j = closeParenStack.Item(i)
inTextRangeStart = InStrRev(Left(text, j), ",")
If inTextRangeStart > 0 Then
text = Left(text, inTextRangeStart - 1) & Mid(text, j + 1)
End If
Next i
End If
cell.Value = text
End If
Next cell
targetRange.Replace What:="@(", Replacement:="", LookAt:=xlPart
targetRange.Replace What:="#=", Replacement:="=", LookAt:=xlPart
MsgBox "Da xoa het ROUND", vbInformation
End SubBạn gửi file tịt lên nhémình test script của bác @CHAOQUAY ảo quá chạy được có 1 lần là tịt, còn script của bác vẫn bị sai trường hợp trước ROUND là dấu-
Ví dụ:=ROUNDDOWN(SUBTOTAL(9;E2:E3);-1)-ROUND(E4+E5;-3)-ROUNDUP(E6-E7;)
Bác fix thử lại, test file nặng cả script của mình xem cái nào nhanh hơn, toàn lệnh replace vớ vẩn mà vẫn chạy được luôn
Mã:Sub XoaRound() Dim cell As Range Dim text As String Dim i As Long Dim j As Long Dim openParenStack As Collection Dim closeParenStack As Collection Dim targetRange As Range Dim openPos As Long Dim inTextRangeStart As Long Dim ws As Worksheet Set ws = ActiveSheet If Selection.Address = ws.Cells.Address Then Set targetRange = ws.UsedRange ElseIf Selection.Rows.Count = ws.Rows.Count Or Selection.Columns.Count = ws.Columns.Count Then Set targetRange = Intersect(ws.UsedRange, Selection) Else Set targetRange = Selection End If targetRange.Replace What:="=", Replacement:="#=", LookAt:=xlPart targetRange.Replace What:="ROUND(", Replacement:="@(", LookAt:=xlPart targetRange.Replace What:="ROUNDDOWN(", Replacement:="@(", LookAt:=xlPart targetRange.Replace What:="ROUNDUP(", Replacement:="@(", LookAt:=xlPart For Each cell In targetRange text = cell.text If InStr(text, "-@(") > 0 Then Set openParenStack = New Collection Set closeParenStack = New Collection For i = 1 To Len(text) Select Case Mid(text, i, 1) Case "(" openParenStack.Add i Case ")" If openParenStack.Count > 0 Then openPos = openParenStack.Item(openParenStack.Count) If Mid(text, openPos - 2, 2) = "-@" Then closeParenStack.Add i End If openParenStack.Remove openParenStack.Count End If End Select Next i If closeParenStack.Count > 0 Then For i = closeParenStack.Count To 1 Step -1 j = closeParenStack.Item(i) inTextRangeStart = InStrRev(Left(text, j), ",") If inTextRangeStart > 0 Then text = Left(text, inTextRangeStart - 1) & Mid(text, j) End If Next i End If cell.Value = text End If Next cell targetRange.Replace What:="-@(", Replacement:="-(", LookAt:=xlPart For Each cell In targetRange text = cell.text If InStr(text, "@(") > 0 Then Set openParenStack = New Collection Set closeParenStack = New Collection For i = 1 To Len(text) Select Case Mid(text, i, 1) Case "(" openParenStack.Add i Case ")" If openParenStack.Count > 0 Then openPos = openParenStack.Item(openParenStack.Count) If Mid(text, openPos - 1, 1) = "@" Then closeParenStack.Add i End If openParenStack.Remove openParenStack.Count End If End Select Next i If closeParenStack.Count > 0 Then For i = closeParenStack.Count To 1 Step -1 j = closeParenStack.Item(i) inTextRangeStart = InStrRev(Left(text, j), ",") If inTextRangeStart > 0 Then text = Left(text, inTextRangeStart - 1) & Mid(text, j + 1) End If Next i End If cell.Value = text End If Next cell targetRange.Replace What:="@(", Replacement:="", LookAt:=xlPart targetRange.Replace What:="#=", Replacement:="=", LookAt:=xlPart MsgBox "Da xoa het ROUND", vbInformation End Sub
Mình có cmt là bị lỗi dấu trừ trước Round đó bác. Kiểu 1 - Round(A2+A3;0) => 1 - A2 + A3
vẫn cái file mình đính kèm ở page 1 đó bác, mình tạo thêm sheet2, sheet3 rồi chạy lần lượt 2 script như bác hướng dan mà chỉ làm được đúng 1 lần.
Ok! Bác có thời gian cứ test nhé. Rảnh em sửa
Để test code bạn chèn thêm sheet2, chép dữ liệu sheet1 sang rồi chạy đoạn code dưới rồi so sánh 2 sheet
Option Explicit
Sub A_Loaitru_1()
Dim Cll As Range
Dim Str_
Dim dgh
Dim slT, slP
Dim i, j, k, x, t
Dim Reg As New RegExp
Reg.Pattern = "ROUND" & "[^\(]*\("
Reg.Global = True
For Each Cll In Sheet2.UsedRange.SpecialCells(xlCellTypeFormulas) '<<--- they doi ten sheet tai day
If Reg.Test(Cll.Formula) Then
Str_ = Cll.Formula
For t = 0 To Reg.Execute(Cll.Formula).Count - 1
k = Reg.Execute(Cll.Formula)(t).FirstIndex + 1
j = InStr(k, Cll.Formula, "(")
i = Space(j - k + 1)
Mid(Str_, k, j - k + 1) = i
dgh = j + 1
slT = 1
slP = 0
Do While slT <> slP
dgh = dgh + 1
If Mid(Cll.Formula, dgh, 1) = "(" Then slT = slT + 1
If Mid(Cll.Formula, dgh, 1) = ")" Then slP = slP + 1
Loop
j = InStrRev(Cll.Formula, ",", dgh)
i = Space(dgh - j + 1)
Mid(Str_, j, dgh - j + 1) = i
Next t
Str_ = Application.Trim(Str_)
Cll.Offset() = Str_
Cll.Offset().Interior.ColorIndex = 6
End If
Next Cll
End Sub
Bạn test thử xem nhé.bác í nhận xét vấn đề mình đưa ra không đáng tốn thời gian, kiểu nó rất xàm xì nên mình phản biện chứ mình đâu phán xét. Các trường hợp đơn giản như bác @cantl nêu ra (công việc của mình cũng chỉ cần đến thế) thì mình xử lý được rồi, mình lập topic hỏi cách huỷ làm tròn trong mọi trường hợp vì tò mò muốn tìm hiểu và mình không nghĩ nó xàm xì đến mức không đáng thảo luận, nghiên cứu.
Mình thêmSelection.Replace What:=",)", Replacement:=",0)", LookAt:=xlPart, sửa B1 thành Selection nhưng test thử một số công thức vẫn gặp lỗi chưa bao quát hết được.
P/s: Hàm bằng chữ dài ngoằng xử lý ngon lành mới sợ
Test thử đi bác
Thanks bác. Script của bác cho kết quả rất chính xác,
-ROUND(A1;-3) cho kết quả là -A1 chứ không phải -(A1) như script của mình, cơ mà test file nặng xíu là not responding !^^Sub LamTron()
Dim ws As Worksheet
Dim roundOption As Variant
Dim targetRange As Range
Dim cell As Range
Dim formulaStr As String
Set ws = ActiveSheet
If Selection.Cells.Count = 1 And Selection.Areas.Count = 1 Then
Set targetRange = ws.UsedRange
Else
Set targetRange = Selection
End If
roundOption = Application.InputBox("Nhap tuy chon cho ROUND (vi du: 0):", "Tuy chon ROUND", Type:=2)
If roundOption = False Then Exit Sub
If roundOption = "" Then roundOption = "0"
If targetRange.Cells.Count <= 1 Then
MsgBox "Ban phai chon vung moi duoc thuc thi!", vbExclamation
Exit Sub
End If
For Each cell In targetRange
If cell.HasFormula Then
formulaStr = cell.Formula
If InStr(formulaStr, "=ROUND") = 0 And _
InStr(formulaStr, "=+ROUND") = 0 And _
InStr(formulaStr, "=-ROUND") = 0 Then
formulaStr = Replace(formulaStr, "=", "=ROUND(", , , vbTextCompare)
formulaStr = formulaStr & "," & roundOption & ")"
cell.Formula = formulaStr
End If
End If
Next cell
MsgBox "Xu ly xong!", vbInformation
End SubBạn muốn code chạy nhanh khi test file nặng thì dùng file này nhé.
For Each cell In targetRange mà script nhanh gấp nghìn lần dã man thật )Sub LamTron()
Dim ws As Worksheet
Dim roundOption As Variant
Dim cell As Range
Dim formulaStr As String
Dim targetRange As Range
Dim i As Long, j As Long
Dim formulas As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws = ActiveSheet
If Selection.Cells.Count = 1 And Selection.Areas.Count = 1 Then
Set targetRange = ws.UsedRange
Else
Set targetRange = Selection
End If
roundOption = Application.InputBox("Nhap tuy chon cho ROUND (vi du: 0):", "Tuy chon ROUND", Type:=2)
If roundOption = False Then Exit Sub
If roundOption = "" Then roundOption = "0"
If Selection.Cells.Count <= 1 And Selection.Areas.Count = 1 Then
MsgBox "Ban phai chon vung moi duoc thuc thi", vbExclamation
Exit Sub
End If
formulas = targetRange.formula
For i = 1 To UBound(formulas, 1)
For j = 1 To UBound(formulas, 2)
If Left(formulas(i, j), 1) = "=" And _
InStr(formulaStr, "=ROUND") = 0 And _
InStr(formulaStr, "=+ROUND") = 0 And _
InStr(formulaStr, "=-ROUND") = 0 Then
formulas(i, j) = Replace(formulas(i, j), "=", "=ROUND(", , , vbTextCompare)
formulas(i, j) = formulas(i, j) & "," & roundOption & ")"
End If
Next j
Next i
targetRange.formula = formulas
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Xu ly xong!", vbInformation
End Sub
' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Private Const projectClassName = "EditorFormulas"
Private Const projectClassVersion = "1.02"
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%
FXs = Array("ROUND", 1, _
"ROUNDUP", 1, _
"ROUNDDOWN", 1)
sheets = Array("Sheet1", "Sheet2", "Sheet3")
file = ThisWorkbook.Path & "\Test huy ROUND.xlsm"
Debug.Print IIf(RemoveFXs(FXs, sheets, file, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub
Private Sub EditorFXInFXs_test()
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
FXs = Array("ROUND", 1, "ROUNDUP", 1, "ROUNDDOWN", 1)
' Sửa ở chỗ này thành vùng chọn Selection
Set rg0 = ActiveSheet.UsedRange ' Selection
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.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Debug.Print timer - t
ActiveSheet.Calculate
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, 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"
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"
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
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 = EditorFXInFXs(s, FXs, True)
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
FXs = Array("ROUND", 0, "ROUNDUP", 1, "ROUNDDOWN", 1)
s = "=@ROUNDDOWN(ROUNDDOWN(ROUNDDOWN(-SUBTOTAL(9,E2:E3),-1),-1),-1)" & _
"-ROUND(-ROUND(-ROUND(-ROUND(-ROUND(-SUBTOTAL(9,E2:E3),-3),-3),-3),-3),-3)" & _
"-ROUNDUP(-ROUNDUP(-ROUNDUP(-ROUNDUP(-ROUNDUP(-SUBTOTAL(9,E2:E3),0),0),0),0),0)" & _
"-ROUNDUP(-ROUNDUP(-ROUNDUP(-ROUNDUP(-ROUNDUP(-Now(),0),0),0),0),0)"
Debug.Print EditorFXInFXs(s, FXs)
End Sub
Function EditorFXInFXs(ByVal expression$, FXs, Optional byFile As Boolean, Optional floor as byte = 10) As String
'Version 1.02
Static re As Object, p4$, p5$, sp$, fl as byte
Dim s$, pp, p1$, p2$, numberParam%, keepParam%, i%, j%, n%, k%, cl, b As Boolean
Set cl = CreateObject("Scripting.Dictionary"): cl.CompareMode = 1
If re Is Nothing 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 & "*"
A:
For i = 1 To floor: p5 = "(?:\(" & Replace(p5, p1, p) & "\)|" & p4 & ")*": Next
p1 = "": p2 = ""
fl = floor
Else
If fl <> floor Then GoTo A
End If
For i = LBound(FXs) To UBound(FXs) Step 2
If FXs(i) <> Empty Then
p1 = FXs(i + 1)
If cl.Exists(p1) Then cl(p1) = cl(p1) & "|" & FXs(i) Else cl(p1) = FXs(i)
End If
Next
For Each pp In cl.keys()
s = "": p1 = "": p2 = "(?:" & cl(pp) & ")": n = CInt(pp)
b = n = 0
For i = 1 To n
If i = n Then
p1 = p1 & IIf(i = 1, "", sp) & "(" & p5 & ")"
Else
p1 = p1 & "(?:" & IIf(p1 = "" Or i = 1, "", sp) & p5 & ")"
End If
Next
If b Then p1 = p1 & "(?:" & p5 & ")"
p1 = p1 & "(?:" & sp & p5 & ")*"
If byFile Then
'> (?:>) < (?:<) & (?:&)
If b Then
p1 = "(?:(?:>=|<=|<>|&|>|<|[\+\*\/\=^" & sp & " -]*|^)(?:@?" & p2 & ")\(" & p1 & "\))"
Else
p1 = "([\*\+\/\(=\^" & sp & " -]|&|>|<|^)(?:@?" & p2 & ")\(" & p1 & "\)"
End If
Else
If b Then
p1 = "(?:(?:>=|<=|<>|[\+\*&\/\\=<>^" & sp & " -]*|^)(?:@?" & p2 & ")\(" & p1 & "\))"
Else
p1 = "([\*\+\/\(=&\^\<>" & sp & " -]|^)(?:@?" & p2 & ")\(" & p1 & "\)"
End If
End If
With re
.Pattern = p1
While .test(expression): expression = .Replace(expression, IIf(b, "", "$1$2")): Wend
End With
Next
If Not byFile Then
With re
.Pattern = "(?:- *- *)+((?:- *){1,2})"
While .test(expression): expression = .Replace(expression, "$1"): Wend
End With
End If
Set cl = Nothing
EditorFXInFXs = expression
End Function
Private Function RecursionRemoveFXInFXs(text1$, text0$, ByVal RegExp)
Dim t$, t0$, s0$, s$, s1$, ms
l:
Do
Set ms = RegExp.Execute(text1)
If ms.Count = 0 Then Exit Do
s = ms(0).submatches(1): s1 = ms(0).submatches(0)
s0 = ms(0): t0 = Mid$(s0, Len(s1) + 1)
text0 = Replace$(text0, s0, s, , , 1): text1 = Replace$(text1, s0, s, , , 1)
' If regexp.test(t0) Then
' t = t0: RecursionRemoveFXInFXs t, text0, regexp
' Debug.Print t0 = t
' If t0 <> t Then text1 = Replace$(text1, s1 & t0, s1 & t, , , 1): text0 = Replace$(text0, s1 & t0, s1 & t, , , 1)
' Else
' End If
Loop
End Function
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Ý tưởng này hay nè, có thể xóa được bất kỳ hàm nào ví dụ mod, quotient, ...
Bác chơi lớn quá... ai chơi lại....
