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á ><
em đưa 1 ví dụ nha bác:
=rounddown(subtotal(9,A1:A2),-1)+round(A3/A4,-3)+roundup(A5/A6,)=subtotal(9,A1:A2)+A3/A4+A5/A6
Đang học Regex trình độ gà nên e tách được trường hợp Round và RoundUp, chờ xem các thành viên khác trên diễn đàn xử lý thêm đồng xem bòn mót được thêm tí nào không. :V.
Function RemoveRound(formula As String) As String
Dim str As String
Dim regRound As Object, regRoundDown As Object, regRoundUp As Object
Set regRound = CreateObject("VBScript.RegExp")
Set regRoundDown = CreateObject("VBScript.RegExp")
Set regRoundUp = CreateObject("VBScript.RegExp")
With regRound
.Pattern = "\bROUND\(([^,]+),[^)]+\)"
.Global = True
.IgnoreCase = True
End With
With regRoundDown
.Pattern = "\bROUNDDOWN\(([^,]+),[^)]+\)"
.Global = True
.IgnoreCase = True
End With
With regRoundUp
.Pattern = "\bROUNDUP\(([^,]+),[^)]+\)"
.Global = True
.IgnoreCase = True
End With
str = regRound.Replace(formula, "$1")
str = regRoundDown.Replace(str, "$1")
str = regRoundUp.Replace(str, "$1")
RemoveRound = str
End Function
Sub test()
Dim str As String
str = "=rounddown(subtotal(9,A1:A2),-1)+round(A3/A4,-3)+roundup(A5/A6,0)"
Range("A3") = RemoveRound(str)
End Subtest thử hàm này không được bác ơi
=LEFT(1+ROUND(1+MID(1+ROUNDUP(A1;0)+1;2;2)+RIGHT(1+ROUNDDOWN(A1;0)+1;2););2)
Không cần test chắc chắn không được nhé bác nhé
Thú thật trước bài này của chủ bài đăng em cũng đã muốn loại hàm round hoặc thêm hàm round vào mà chưa nghĩ ra phương án nào hợp lý. Phần này của bác em cũng đã nghĩ qua nhưng chưa tìm được giải thuật cho hợp lý kể cả đếm số lượng "(" và ")"
Đáng hay không thì người bỏ công ra làm mới biết, bạn chỉ đưa ra yêu cầu nhưng không biết được để thực hiện yêu cầu đó cần phải làm những gì thì không thể nào biết được có đáng hay không.
Option Explicit
Option Compare Text
Option Private Module
Private Enum FormulaExpressionsType
fptElement = 0
fptFunction
fptArgument
fptGroup
End Enum
Private Enum ParameterTextType
pttFxStart = 1
pttSheetObject
pttSheetObjectSpecial
pttCell
pttNumber
pttNumberInArray
pttString
pttStringInArray
pttArgumentBreak
pttArray
pttTable
pttTableAt
pttTableGroup
pttTableGroup1
pttTableGroup2
pttTableGroup20
pttKeywork
pttKeyworkStart2
pttBlockStart
pttBlankMark
End Enum
Private Enum FxParseSyntaxError
DPSENotSupportSeparator = 800
DPSEBlockClosedNotValid
DPSEBlockClosedOutside
DPSEKeywordNotValid
DPSETwoLockRange
DPSESyntaxError
DPSENumberLongNotValid
DPSESeparatorArray
DPSESyntaxOfCell
DPSEZeroBeforeColonCell
DPSESheetRoot
DPSESpillOperator
DPSEZeroFront
DPSE9
End Enum
Public Enum MainSyntaxExpressions
MSE
MSEBracketOpen ' ' (
MSEBracketClose ' ' )
MSESeparator ' ' ; ,
MSESeparatorArray ' ; , /
MSEOperator ' ' + - * / = > < >= <= <> &
MSESign ' ' --
MSEFunc ' ' Now() ...
MSEBoolean ' ' TRUE FALSE
MSENumber ' ' -12.23
MSEString ' ' "abc" """a"""
MSEErrVar ' ' #REF! #NULL! #DIV/0! #VALUE! #NAME? #NUM! #N/A #SPILL! #CALC!
'
MSERange ' ' A1:A2
MSENamed ' ' abcdef09
MSETable ' ' [#All] [#Headers] [#Totals] [#Data] [#This Row]
' ' [@[column 1]] table1[column 1]
MSEArray ' ' {1,2,3;4,5,6;"a","b","c";TRUE,TRUE,TRUE}
' {1\2\3;4\5\6;"a"\"b"\"c";TRUE\TRUE\TRUE}
MSEiio ' ' @ implicit intersection operator
MSEArrayReference ' # Array Reference of a Cell Address
End Enum
Private Enum SyntaxKeyExpressions
skeFxStart = 1
skeFx
skeFxNotArguments
skeNamed
skeSheet
'------------------------
skeRootBlockOpen
skeRootOpen
skeRootName
skeRootClose
skeRootSheet
skeRootBlockClose
skeRoot
'------------------------
skeCell
skeCellBreak
skeCellLock
skeCellAddress
skeCellDigitAddress
skeCellColon
skeCellErrREF
skeSpillOperator
skeFxIf
skeFxIfs
skeFxIfna
skeFxIferror
skeFxINDIRECT
skeConstantsString
skeConstantsBoolean
skeNumber
skeNumberLong
skeNumberDecimal
skeArgumentSeparator
skeArrayRowSeparator
skeArrayColumnSeparator
skeArray
skeKeywork
skeKeyworkUnderscore
skeExpressionsError
skeSignNumber
skeOperatorCompare
skeOperatorArithmetic
skeOperatorPercent
skeOperatorText
skeExpressions
skeCommunicationMark
skeAppClassMark
skeBlock
skeBlockStart
skeBlockClose
skeLockProject
skeImplicitIntersectionOperator
End Enum
Private Enum SyntaxGroupExpressions
sgeFx
sgeFxNotArguments
sgeNamed
sgeObject
sgeSheet
sgeRoot
sgeSpillOperator
sgeFxINDIRECT
sgeConstantsString
sgeConstantsBoolean
sgeNumber
sgeArgumentSeparator
sgeArrayRowSeparator
sgeArrayColumnSeparator
sgeArray
sgeExpressionsError
sgeSignNumber
sgeOperatorCompare
sgeOperatorArithmetic
sgeOperatorPercent
sgeOperatorText
sgeExpressions
sgeCommunicationMark
sgeAppClassMark
sgeBlockStart
sgeLockProject
sgeImplicitIntersectionOperator
End Enum
Private Const n_ = vbNullString
Private Sub FxParseConvert_test()
Dim s
' 0 1 2 3 4
l___1_______________: s = "=""Hello"""
l___2_______________: s = s & "&"
s = s & "-@$A$1 + -PI() + "
s = s & "'[FindCellReferences.xlsm]Sheet1'!B2:X '[FindCellReferences.xlsm]Sheet1'!C2:F + "
l___3_______________: s = s & "S_List("
s = s & " -$A$6:$M$1200,"
l___3__1____________: s = s & " Sheet1!A4:M11:O12:Q13,"
l___3__2____________: s = s & " INDIRECT(""A9""),"
l___3__3____________: s = s & " SUM(A4,A7),"
l___3__4____________: s = s & " 2%,"
l___3__5____________: s = s & " S_Cells("
l___3__5___0________: s = s & " [@[Header1]],"
l___3__5___1________: s = s & " Table2[Header1],"
l___3__5___2________: s = s & " Table2[ [#Data],[Header1] ],"
l___3__5___3________: s = s & " Table2[ [#Headers],[#Data],[Header 2] ],"
l___3__5___4________: s = s & " Table2[[ Header3 ]],"
l___3__5___5________: s = s & " Table2[[Header1]:[Header 2]],"
l___3__5___6________: s = s & " H3:L18,"
l___3__5___7________: s = s & " Sheet1!B2:F17,"
l___3__5___8________: s = s & " 'Sheet1'!B2:F,"
l___3__5___9________: s = s & " '[FindCellReferences.xlsm]Sheet1'!B2:X,"
l___3__5___10_______: s = s & " Table1[column1] Table2[column1],"
l___3__5___11_______: s = s & " [@[Header1]] [@[Header2]]"
l___3__5e___________: s = s & " ),"
l___3__6____________: s = s & " ""Data Testing"","
l___3__7____________: s = s & " 1,"
l___3__8___1________: s = s & " ("
l___3__8___1___1____: s = s & " (1/2+20)*(25-7)"
l___3__8___1e_______: s = s & " )/10,"
l___3__9____________: s = s & " {2;3;4},"
l___3_10____________: s = s & " TRUE"
l___3e______________: s = s & ")"
l___4_______________: s = s & "+"
l___5_______________: s = s & "1000"
l___6_______________: s = s & "+"
l___7_______________: s = s & "("
l___7__1____________: s = s & " (SUM(A1:B9)/2)"
l___7e______________: s = s & ")"
Debug.Print s
Dim Fx1$, Fx2$, e1&, e2$
Call FxParseConvert(formula:=s, SpacesIndent:=3, conversion:=0, FxMinified:=Fx1, FxFormated:=Fx2, errNumber:=e1, errDescription:=e2)
Debug.Print e2
If e1 = 0 Then
Debug.Print Fx1
Debug.Print Fx2
End If
End Sub
Private Function FxParseConvert(ByVal formula, Optional ByVal RemoveFXs As Collection, Optional FxMinified$, Optional FxFormated$, Optional SpacesIndent = 3, _
Optional conversion%, Optional errNumber As Long, _
Optional errDescription$, Optional defaultSeparatorSettings As Boolean) As String
errNumber = 0: errDescription = n_
Const id = 2
On Error Resume Next
Dim tp As Boolean, av As Long, io1$, io2$, pt1$, pt2$, pt3$, pt4$, pt5$
pt1 = "A-Za-z" & ChrW$(&H80) & "-" & ChrW$(&HFFFF&)
pt2 = "[_0-9" & pt1 & "]"
pt3 = "[_.0-9" & pt1 & "]"
pt4 = "[$_0-9" & pt1 & "]"
pt1 = "[" & pt1 & "]"
pt5 = "_xnlf." & pt1
tp = TypeName(formula) = "Range"
Call OfficeVersion(newVersion:=av, implicitIntersectionOperator:=io1, SpillOperator:=io2)
Dim r%, c%, rc%, cc%, uCells As Range, Cell As Range, z$, z2$, t, t1$, T2$, t3$, l, i%, i2%, si%, m1$, m2$, m12$, m3$, a, ae, ae2, o%
Dim y As Boolean, uc As Boolean
Dim Floor%, nfloor%, index%, ds$, sv$, sb$, ab$, ds0$, sb0$, ab0$, ds1$, sb1$, ab1$, ds2$, sb2$, ab2$, rr$, ss$, nr0$, nr1$, nr2$
Dim ee As FxParseSyntaxError, ras As Boolean, ccas%, d1 As MainSyntaxExpressions, fxSyntaxs As Collection, fxSyntax As clsFxSyntax
Dim floors%(0 To 200), blocks$(0 To 1, 0 To 200), iaFX%(0 To 200)
Dim gt As SyntaxKeyExpressions, gt2 As SyntaxKeyExpressions
Dim FA As ParameterTextType, FA2 As ParameterTextType
Dim aa, aa1, ia%, pfxs As Collection, pfx As clsFxParse, xfx As ClsFX, Blocked As Boolean
ae = Array("#REF!", "#NULL!", "#DIV/0!", "#VALUE!", "#NAME?", "#NUM!", "#N/A", "#SPILL!", "#CALC!")
ae2 = Array("[#All]", "[#Headers]", "[#Totals]", "[#Data]", "[#This Row]")
If Application.UseSystemSeparators Then
ds1 = Application.International(xlDecimalSeparator)
Else
ds1 = Application.DecimalSeparator
End If
Select Case ds1
Case ".": sb1 = ",": ab1 = ",": sb2 = ";": ab2 = "\": ds2 = ","
Case ",": sb1 = ";": ab1 = "\": sb2 = ",": ab2 = ",": ds2 = "."
Case Else:
ee = DPSENotSupportSeparator: GoTo ErrorSyntax
'MsgBox TimeOutSeconds:=6, _
title:="Canh.r bao.s!", _
Prompt:="Chuyen.er ddoi.or cu.s phap.s cong.o thuc.ws:\n chi.r ho.ox tro.wj dau.as thap.aj phan.a (,) hoac.wj (.)\n" & _
"Ban.j can.af cai.f ddat.wj lai.j tai.j File\/Options\/Advanced\/...separators"
Exit Function
End Select
If (tp Or defaultSeparatorSettings) Then ds = ds1: GoSub separators
nr0 = "="
If tp Then
rc = formula.rows.count
cc = formula.columns.count
For r = 1 To rc
For c = 1 To cc
Set Cell = formula(r, c).MergeArea
If Not uCells Is Nothing Then
uc = Intersect(uCells, Cell) Is Nothing
Set uCells = union(uCells, Cell)
Else
Set uCells = Cell: uc = True
End If
If uc Then
If Cell.HasFormula Then
If av And conversion <> 4 Then t = Cell.Formula2 Else t = Cell.formula
T2 = t
si = 2: l = Len(t): GoSub ParseConvert
If Cell.HasArray And Abs(conversion) = 4 Then
t = "ARRAYFORMULA(" & t & ")"
T2 = nr0 & "ARRAYFORMULA(" & T2 & ")"
Else
t = nr0 & t: T2 = nr0 & " " & T2
End If
ElseIf IsNumeric(Cell.Value) Then
t = Replace(Cell.Value, ds, ds0)
T2 = t
Else
t = n_: T2 = t
End If
z = z & t: z2 = z2 & T2
End If
If c < cc Then z = z & vbTab: z2 = z2 & vbTab
Next
If r < rc Then z = z & vbNewLine: z2 = z2 & vbNewLine
Next
FxMinified = z: FxFormated = z2
Else
t = formula: l = Len(t): T2 = t
If t Like "=*" Then si = 2 Else si = 1
GoSub ParseConvert
FxMinified = nr0 & t: FxFormated = nr0 & " " & T2
End If
Exit Function
ParseConvert:
Set pfxs = New Collection: Set xfx = Nothing: Set pfx = Nothing
Set fxSyntaxs = New Collection
nw:
FA = 0: rr = n_: ss = n_: t1 = n_: Floor = 0: gt = 0: gt2 = 0
For i = si To l
a:
m1 = Mid$(t, i, 1): nr1 = n_: nr2 = n_: d1 = 0
d:
Select Case FA
Case 0
t1 = n_
Select Case m1
Case "$": t1 = m1: m1 = sv & m1: sv = n_: FA = pttCell: gt2 = skeCellLock
Case """": t1 = m1: m1 = sv & m1: sv = n_: FA = pttString
Case "[":
GoSub NextChar1:
If m2 = "@" Then Debug.Print "@: "; FA; pttTable; pttTableGroup: FA = pttTable: t1 = m12: m1 = sv & m12: i = i + 1 Else t1 = m1: m1 = sv & m1: FA = pttSheetObject: gt2 = skeRootName
sv = n_:
Case "'": t1 = m1: m1 = sv & m1: sv = n_: FA = pttSheetObjectSpecial: gt2 = skeRootBlockOpen
Case "{": t1 = m1: m1 = sv & m1: sv = n_: FA = pttArray
Case io1: sv = sv & m1: m1 = n_: gt2 = skeImplicitIntersectionOperator
Case "_": t3 = Mid$(t, i, 7)
If t3 Like pt5 Then
t1 = t3: m1 = sv & m1: FA = pttKeywork: gt2 = skeKeyworkUnderscore: i = i + 6
Else
ee = DPSESyntaxError: GoTo ErrorSyntax
End If
Case "#":
For Each a In ae
If a = Mid$(t, i, Len(a)) Then m1 = a: i = i + Len(a) - 1: gt2 = skeExpressionsError: d1 = MSEErrVar: GoTo n
Next
ee = DPSESyntaxError: GoTo ErrorSyntax
Case "(": GoSub skipUselessCharacters: If o = 1 Then ee = DPSEBlockClosedNotValid: GoTo ErrorSyntax
m1 = sv & m1: sv = n_: d1 = MSEBracketOpen:
GoSub oneArgument
Floor = Floor + 1
If o = 0 Then
nr1 = vbLf & Space(Floor * SpacesIndent + id)
floors(Floor) = 0
Else
floors(Floor) = 1
End If
blocks(0, Floor) = ")": FA = 0: t1 = n_
gt2 = skeBlockStart
Case ")": d1 = MSEBracketClose
If Floor - 1 < 0 Then
ee = DPSEBlockClosedOutside: GoTo ErrorSyntax
End If
If floors(Floor) = 1 Then
nr1 = nr1 & vbLf & Space((Floor - 1) * SpacesIndent + id)
Else
If floors(Floor + 1) = 1 Then nr1 = nr1 & vbLf & Space((Floor - 1) * SpacesIndent + id): floors(Floor + 1) = 0
End If
blocks(1, Floor) = n_
floors(Floor) = 0: Floor = Floor - 1: o = 0
Case blocks(1, Floor): m1 = sb0: nr1 = n_: nr2 = vbLf & Space(Floor * SpacesIndent + id): gt2 = skeArgumentSeparator: d1 = MSESeparator
Case " ", vbLf: GoTo n2
Case "%": gt2 = skeOperatorPercent
Case "&": nr1 = " ": nr2 = " ": gt2 = skeOperatorText: d1 = MSEOperator
Case "*", "^", "/": gt2 = skeOperatorArithmetic: nr1 = " ": nr2 = " ": d1 = MSEOperator
Case "+", "-":
Select Case gt2
Case skeSignNumber, skeArgumentSeparator, skeBlockStart, skeOperatorText: sv = sv & m1: m1 = n_: gt2 = skeSignNumber: d1 = MSESign
Case skeOperatorArithmetic: sv = sv & m1: m1 = n_: gt2 = skeOperatorArithmetic: d1 = MSEOperator
Case Else: nr1 = " ": nr2 = " ": sv = n_: gt2 = skeOperatorArithmetic: d1 = MSEOperator
End Select
Case Else:
Select Case True
Case sb = n_ And m1 Like "[,;]": ds = IIf(m1 = ";", ",", "."): d1 = MSESeparator: GoSub separators: GoTo nw
Case m1 Like "#": m1 = sv & m1: t1 = m1: FA = pttNumber: gt2 = skeNumber: sv = n_
Case m1 Like pt1: t1 = sv & m1: FA = pttKeywork: m1 = n_: sv = n_
Case Else
GoSub NextChar1
Select Case True
Case m12 = "<=", m12 = ">=", m12 = "<>": m1 = m12: nr1 = " ": nr2 = " ": i = i + 1: gt2 = skeOperatorCompare
Case m1 Like "[=<>]": nr1 = " ": nr2 = " ": gt2 = skeOperatorCompare
Case Else: ee = DPSEKeywordNotValid: GoTo ErrorSyntax
End Select
End Select
End Select
Case pttKeywork:
Select Case True
Case m1 Like ".": GoSub NextChar1: i = i + 1: If m2 Like pt1 Then m1 = m1 & m2 Else ee = DPSEKeywordNotValid: GoTo ErrorSyntax
t1 = t1 & m1
Case m1 Like pt2: t1 = t1 & m1
If i = l Then d1 = MSENamed: GoSub add: GoSub addExpressions
Case m1 Like "[*, )=<>+/^&#" & vbLf & "-]" Or i = l:
Select Case t1
Case "TRUE", "FALSE": gt2 = skeConstantsBoolean
Case Else: gt2 = skeCell:
End Select
GoSub add: GoSub addExpressions: GoTo d
Case m1 Like "[:!$]": t1 = t1 & m1: FA = pttCell: GoSub add:
Select Case m1
Case "$": gt2 = skeCellLock
Case ":": gt2 = skeCellColon
Case "!": gt2 = skeCellAddress
End Select
Case m1 = "[": t1 = t1 & m1: FA = pttTable: GoSub add:
Case m1 = "(": d1 = MSEFunc
Err.Clear: aa = RemoveFXs(t1): aa1 = aa(0): ia = aa(1)
Err.Clear: Set pfx = pfxs(t1):
If Err Then
pfxs.add New clsFxParse, t1:
Set pfx = pfxs(t1)
With pfx
.FirstIndex = i
.FuncName = t1
End With
End If
Set xfx = pfx.FxLast(True)
t1 = t1 & m1
GoSub skipUselessCharacters
If o Then
m1 = ")": t1 = t1 & m1: GoSub add: gt2 = skeFxNotArguments: GoSub addExpressions
Else
GoSub oneArgument
If o = 0 And gt2 > 0 And gt2 <> skeArgumentSeparator Then nr1 = vbLf & Space(Floor * SpacesIndent + id)
gt2 = skeFxStart: Floor = Floor + 1
blocks(0, Floor) = m1
blocks(1, Floor) = sb
If o = 0 Then
m1 = t1
floors(Floor) = 1: nr2 = vbLf & Space(Floor * SpacesIndent + id)
FA = 0: t1 = n_: GoTo n
Else
floors(Floor) = 0: GoSub add
End If
FA = 0: t1 = n_
End If
Case i = l
Case Else: GoSub add: FA = 0: GoTo d
End Select
m1 = n_
Case pttTable, pttTableGroup, pttTableGroup1, pttTableGroup2, pttTableGroup20:
'https://support.microsoft.com/en-us/office/using-structured-references-with-excel-tables-f5ed2452-2337-4f71-bed3-c8ae6d2b276e
Select Case FA
Case pttTable, pttTableGroup1, pttTableGroup20:
Select Case m1:
' Case "#":
' For Each a In ae2
' If a = Mid$(T, i, Len(a)) Then m1 = a: i = i + Len(a) - 1: Exit For
' Next
Case "[": FA = pttTableGroup2
Case "]": FA = 0
Case " ":
Select Case FA
Case pttTable: FA = pttTableGroup: m1 = ""
Case pttTableGroup20: m1 = ""
End Select
Case "'": i = i + 1: m1 = Mid$(t, i, 2)
Case Else:
End Select
Case pttTableGroup:
Select Case m1:
Case "[": FA = pttTableGroup2
Case "]": FA = 0: m1 = " ]"
Case Else: FA = pttTableGroup1: m1 = " " & m1
End Select
Case pttTableGroup2:
Select Case m1:
Case "'": i = i + 1: m1 = Mid$(t, i, 2)
Case "]": FA = pttTableGroup20: GoSub NextChar1: If m2 Like "[,;]" Then i = i + 1: m1 = m1 & sb0: If ds = n_ Then ds = IIf(m2 = ";", ",", "."): GoSub separators: GoTo nw
End Select
End Select
Case pttNumber, pttNumberInArray:
Select Case True
Case m1 = ":": FA = pttCell
Case ds = n_ And m1 = ".": t1 = t1 & m1: ds = m1: GoSub separators: GoTo nw
Case m1 Like "#": t1 = t1 & m1: gt2 = skeNumber
Case m1 Like "[eE]": If gt2 = skeNumberLong Then ee = DPSENumberLongNotValid: GoTo ErrorSyntax:
gt2 = skeNumberLong
GoSub NextChar1: i = i + 1: If m2 Like "[+-]" Then m1 = m1 & m2 Else ee = DPSENumberLongNotValid: GoTo ErrorSyntax
GoSub NextChar1: i = i + 1: If m2 Like "#" Then m1 = m1 & m2 Else ee = DPSENumberLongNotValid: GoTo ErrorSyntax
t1 = t1 & m1
Case m1 = ds: m1 = ds0: t1 = t1 & m1: If gt2 = skeNumberLong Then ee = DPSENumberLongNotValid: GoTo ErrorSyntax: GoTo d
Case m1 Like "[*;, )=<>+/^&#%}" & vbLf & "\-]" Or i = l: FA = IIf(FA = pttNumberInArray, pttArray, 0): GoTo d
Case Else: ee = DPSESyntaxError: GoTo ErrorSyntax
End Select
Case pttString, pttStringInArray:
If m1 = """" Then
GoSub NextChar1: If m2 = """" Then t1 = t1 & m1: m1 = m1 & m2: i = i + 1 Else gt2 = skeConstantsString: If FA = pttStringInArray Then FA = pttArray Else d1 = MSEString: GoSub addExpressions
Else
If i = l Then ee = DPSESyntaxError: GoTo ErrorSyntax
End If
Case pttSheetObject: t1 = t1 & m1
Select Case True
Case m1 = "!" And gt2 = skeRootSheet: FA = pttCell: gt2 = skeRoot: Return
Case m1 = "]" And gt2 = skeRootName: gt2 = skeRootSheet
Case m1 Like pt3 And gt2 = skeRootName:
Case m1 Like pt2 And gt2 = skeRootSheet
Case Else: GoTo ErrRootCell
End Select
Case pttSheetObjectSpecial: t1 = t1 & m1
Select Case True
Case m1 = "[": If gt2 <> skeRootBlockOpen Then GoTo ErrRootCell
gt2 = skeRootOpen
Case m1 = "]": If gt2 <> skeRootName Then GoTo ErrRootCell
gt2 = skeRootClose
Case m1 = "'": If i = l Then GoTo ErrRootCell
If gt2 <> skeRootSheet Then GoTo ErrRootCell
m2 = Mid$(t, i + 1, 1)
If m2 <> "'" Then
If m2 <> "!" Then GoTo ErrRootCell
gt2 = skeRoot: FA = pttCell
End If
m1 = m1 & m2: t1 = t1 & m2: i = i + 1
Case Else:
'check characters
Select Case gt2
Case skeRootBlockOpen: If Not m1 Like "[_A-Za-z0-9]" Then GoTo ErrRootCell
gt2 = skeRootSheet
Case skeRootOpen, skeRootName: gt2 = skeRootName
Case skeRootClose, skeRootSheet: gt2 = skeRootSheet
Case Else: GoTo ErrRootCell
End Select
End Select
Case pttCell:
'' A1 A1:A5 1:1 A2:A A:A $A$1 $A$1:$A$5 $1:$1 $A$2:$A $A:$A
Select Case True
Case m1 = "#": m1 = Mid$(t, i, 5): If Mid$(t, i, 5) <> ae(0) Then ee = DPSESyntaxError: GoTo ErrorSyntax
i = i + 4: FA = 0: gt2 = skeCellErrREF
Case m1 = "$":
Select Case gt2
Case 0, skeRoot, skeCellAddress, skeCellColon: gt2 = skeCellLock
Case Else: ee = DPSETwoLockRange: GoTo ErrorSyntax
End Select
Case m1 Like "[A-Za-z]":
Select Case gt2
Case 0, skeRoot, skeCellLock, skeCellAddress, skeCellColon: gt2 = skeCellAddress
Case Else: ee = DPSESyntaxOfCell: GoTo ErrorSyntax
End Select
Case m1 Like "[0-9]":
Select Case gt2
Case 0, skeRoot, skeCellColon: gt2 = skeCellDigitAddress: If m1 = "0" Then ee = DPSEZeroFront: GoTo ErrorSyntax
Case skeCellLock, skeCellAddress, skeCellDigitAddress: gt2 = skeCellDigitAddress
Case Else: ee = DPSESyntaxOfCell: GoTo ErrorSyntax
End Select
Case m1 = ":":
Select Case gt2
Case skeCellAddress, skeCellDigitAddress: gt2 = skeCellColon
Case Else: ee = DPSESyntaxOfCell: GoTo ErrorSyntax
End Select
Case m1 = io2:
Select Case gt2
Case skeSpillOperator, skeCellAddress, skeCellDigitAddress: gt2 = skeSpillOperator
Case Else: ee = DPSESpillOperator: GoTo ErrorSyntax
End Select
Case Else: o = 0
#If DevCoding Then
'If sb <> n_ Then Debug.Print "Cell:"; t1
#End If
If m1 = " " Then If gt2 = skeCellAddress Then GoSub twoReferences
If o = 0 Then d1 = MSERange: GoSub addExpressions: GoTo d
End Select
t1 = t1 & m1
Case pttArray:
t1 = t1 & m1:
Select Case m1
Case "-": t3 = Mid$(t, i + 1, 1): If t3 Like "#" Then m1 = m1 & t3: FA = pttNumberInArray: gt2 = skeNumber Else ee = skeConstantsBoolean: GoTo ErrorSyntax
Case "0" To "9": FA = pttNumberInArray: gt2 = skeNumber
Case """": FA = pttStringInArray: ras = False: ccas = 0
Case "}": gt2 = skeArray: ras = False: ccas = 0: d1 = MSEArray: GoSub addExpressions
Case "\", ab: If ab = n_ Then ds = ",": GoSub separators: GoTo nw
m1 = ab0: nr2 = " "
Case ";": ras = True: ccas = 0: m1 = m1 & " "
Case ",":
If ab <> Empty Then ee = DPSESeparatorArray: GoTo ErrorSyntax
Select Case gt2
Case skeConstantsString, skeConstantsBoolean: ds = ".": GoSub separators: GoTo nw
Case Else: ccas = ccas + 1: If ccas >= 2 Then ds = ".": GoSub separators: GoTo nw
End Select
m1 = ab0:
Case "T": t3 = Mid$(t, i, 4): If t3 = "TRUE" Then m1 = t3: gt2 = skeConstantsBoolean: ccas = 0: i = i + 3 Else ee = skeConstantsBoolean: GoTo ErrorSyntax
Case "F": t3 = Mid$(t, i, 5): If t3 = "FALSE" Then m1 = t3: gt2 = skeConstantsBoolean: ccas = 0: i = i + 4 Else ee = skeConstantsBoolean: GoTo ErrorSyntax
Case " ", vbLf: m1 = n_
Case Else: ee = pttArray: GoTo ErrorSyntax
End Select
End Select
n:
If Not Blocked Then
ss = ss & m1
rr = rr & nr1 & m1 & nr2
End If
n2:
If d1 > 0 Then
fxSyntaxs.add New clsFxSyntax
Set fxSyntax = fxSyntaxs(fxSyntaxs.count)
With fxSyntax
.defined = d1
.FirstIndex = d1
.EndIndex = i
.Floor = Floor
.indentLevel = Floor
.syntax = t1
End With
End If
Next
If ds <> n_ Then t = ss & t1: T2 = rr & t1
Return
add: ss = ss & t1: rr = rr & t1: t1 = n_
Return
twoReferences:
For i2 = i + 1 To l
m3 = Mid$(t, i2, 1)
Select Case True
Case m3 = " ", m3 = vbLf:
Case m3 = "'": m1 = m1 & m3: i = i2: o = 1: FA = pttSheetObjectSpecial: gt2 = skeRootBlockOpen: Return
Case m3 = "[":
m1 = m1 & m3: i = i2: o = 1: FA = pttSheetObject: gt2 = skeRootName:
m2 = Mid$(t, i2 + 1, 1)
If m2 = "@" Then m1 = m1 & m2: FA = pttTable: i = i2 + 1 Else FA = pttSheetObject: gt2 = skeRootName
Return
Case m3 Like "[$'_A-Za-z0-9]": m1 = m1 & m3: i = i2: o = 1: Return
Case Else: i = i2 - 1: Return
End Select
Next
Return
NextChar1:
If i < l Then m2 = Mid$(t, i + 1, 1): m12 = m1 & m2 Else m2 = n_: m12 = n_
Return
NextChar2:
For i2 = i + 1 To l
m3 = Mid$(t, i2, 1): Select Case m3: Case " ", vbLf: Case Else: m2 = m3: Return: End Select
Next
m2 = n_
Return
NextChar3:
If i2 < l Then m2 = Mid$(t, i2 + 1, 1) Else m2 = n_
Return
Percentage: y = False
For i2 = i + 1 To l
Select Case Mid$(t, i2, 1)
Case " ", vbLf:
Case "%": y = True: i = i2: Exit For
Case Else: Exit For
End Select
Next
Return
skipUselessCharacters: o = 0
For i2 = i + 1 To l
Select Case Mid$(t, i2, 1)
Case " ", vbLf:
Case ")": o = 1: i = i2: Exit For
Case Else: i = i2 - 1: Exit For
End Select
Next
Return
oneArgument: FA2 = 0: o = 0: nfloor = Floor
For i2 = i + 1 To l
m3 = Mid$(t, i2, 1)
Select Case FA2
Case 0
Select Case m3
Case """": FA2 = pttString
Case "'": FA2 = pttSheetObjectSpecial:
Case "{": FA2 = pttArray
Case ")": o = 1: nfloor = nfloor - 1: If nfloor = (Floor - 1) Then Return
Case sb, ";": Return
Case "(": nfloor = nfloor + 1
End Select
Case pttString, pttStringInArray: If m3 = """" Then GoSub NextChar3: If m2 = """" Then i2 = i2 + 1 Else FA2 = IIf(FA2 = pttStringInArray, pttArray, 0)
Case pttSheetObjectSpecial: If m3 = "'" Then GoSub NextChar3: If m2 = "'" Then i2 = i2 + 1 Else FA2 = 0
Case pttArray:
Select Case m3
Case """": FA2 = pttStringInArray
Case "}": FA2 = 0
End Select
Case pttTable, pttTableGroup1, pttTableGroup20:
Select Case m3:
Case "[": FA2 = pttTableGroup2
Case "]": FA2 = 0
Case " ": If FA2 = pttTable Then FA2 = pttTableGroup
Case "'": i2 = i2 + 1
End Select
Case pttTableGroup: Select Case m3: Case "[": FA2 = pttTableGroup2: Case "]": FA2 = 0: Case Else: FA2 = pttTableGroup1: End Select
Case pttTableGroup2: Select Case m3:: Case "'": i2 = i2 + 1:: Case "]": FA2 = pttTableGroup20:: End Select
End Select
Next
ee = DPSESyntaxError: GoTo ErrorSyntax
Return
addExpressions:
t1 = n_: FA = 0
Return
separators:
Select Case ds
Case ".": sb = ",": ab = ","
Case ",": sb = ";": ab = "\"
End Select
Select Case True
Case ds1 = "." And conversion = 4: ds0 = ds1: sb0 = sb1: ab0 = ab1
Case ds1 = "." And conversion = -4: ds0 = ds2: sb0 = sb2: ab0 = ab2
Case ds1 = "," And conversion = 4: ds0 = ds1: sb0 = sb1: ab0 = ab1
Case ds1 = "," And conversion = -4: ds0 = ds2: sb0 = sb2: ab0 = ab2
Case ds1 = "." And conversion = 3: ds0 = ds1: sb0 = sb1: ab0 = ab1
Case ds1 = "." And conversion = -3: ds0 = ds2: sb0 = sb2: ab0 = ab2
Case ds1 = "," And conversion = 3: ds0 = ds1: sb0 = sb1: ab0 = ab1
Case ds1 = "," And conversion = -3: ds0 = ds2: sb0 = sb2: ab0 = ab2
Case ds = "." And conversion = 2: ds0 = ds1: sb0 = sb1: ab0 = ab1
Case ds = "." And conversion = -2: ds0 = ds2: sb0 = sb2: ab0 = ab2
Case ds = "," And conversion = 2: ds0 = ds1: sb0 = sb1: ab0 = ab1
Case ds = "," And conversion = -2: ds0 = ds2: sb0 = sb2: ab0 = ab2
Case conversion = 1: ds0 = ".": sb0 = ",": ab0 = ","
Case conversion = -1: ds0 = ",": sb0 = ";": ab0 = "\"
Case Else: ds0 = ds: sb0 = sb: ab0 = ab
End Select
Return
ErrRootCell:
ee = DPSESheetRoot: GoTo ErrorSyntax
Exit Function
ErrorSyntax:
errNumber = ee: rr = n_
Select Case ee
Case DPSENotSupportSeparator: rr = "Kh" & ChrW(244) & "ng h" & ChrW(7895) & " tr" & ChrW(7907) & " ph" & ChrW(226) & "n t" & ChrW(237) & "ch d" & ChrW(7845) & "u ph" & ChrW(226) & "n t" & ChrW(225) & "ch " & ChrW(273) & ChrW(7889) & "i s" & ChrW(7889) & " hi" & ChrW(7879) & "n t" & ChrW(7841) & "i!"
Case DPSEBlockClosedNotValid: rr = "Nh" & ChrW(243) & "m bi" & ChrW(7875) & "u th" & ChrW(7913) & "c " & ChrW(273) & ChrW(243) & "ng kh" & ChrW(244) & "ng h" & ChrW(7907) & "p l" & ChrW(7879) & "!"
Case DPSEBlockClosedOutside: rr = "L" & ChrW(7895) & "i d" & ChrW(432) & " d" & ChrW(7845) & "u "")"" " & ChrW(273) & ChrW(243) & "ng nh" & ChrW(243) & "m bi" & ChrW(7875) & "u th" & ChrW(7913) & "c!"
Case DPSEKeywordNotValid: rr = "K" & ChrW(253) & " t" & ChrW(7921) & " kh" & ChrW(244) & "ng h" & ChrW(7907) & "p l" & ChrW(7879) & ")"
Case DPSETwoLockRange: rr = "L" & ChrW(7895) & "i k" & ChrW(253) & " t" & ChrW(7921) & " kh" & ChrW(243) & "a " & ChrW(273) & ChrW(244) & "i trong khai b" & ChrW(225) & "o Range!"
Case DPSESyntaxError: rr = ""
Case DPSENumberLongNotValid: rr = "C" & ChrW(250) & " ph" & ChrW(225) & "p s" & ChrW(7889) & " d" & ChrW(224) & "i kh" & ChrW(244) & "ng h" & ChrW(7907) & "p l" & ChrW(7879) & "!"
Case DPSESeparatorArray: rr = "D" & ChrW(7845) & "u ph" & ChrW(226) & "n t" & ChrW(225) & "ch gi" & ChrW(225) & " tr" & ChrW(7883) & " m" & ChrW(7843) & "ng kh" & ChrW(244) & "ng h" & ChrW(7907) & "p l" & ChrW(7879) & "!"
End Select
If (i - 6) < 0 Then
ss = Mid$(t, 1, 6) & "...": i2 = i
ElseIf (i + 10) > l Then
i2 = 10 - (l - i) + 3: ss = "..." & Right(t, 10)
Else
ss = "..." & Mid$(t, i - 6, 12) & "...": i2 = 10
End If
errDescription = vbLf & "[Error syntax: " & CStr(ee) & vbLf & _
"| " & rr & IIf(rr = n_, "", vbLf) & _
"| Location: " & i & "" & vbLf & _
"| " & Space(i2 - 1) & "|" & vbLf & _
"| " & Space(i2 - 1) & "v" & vbLf & _
"| " & ss & vbLf & _
"]"
End Function
Private Function OfficeVersion(Optional newVersion As Long, Optional implicitIntersectionOperator$, Optional SpillOperator$) As Long
Static n&, v&, i1$, i2$
If v <> 0 Then GoTo E
Dim registryObject As Object
Dim rootDirectory$
Dim keyPath$
Dim arrEntryNames As Variant
Dim arrValueTypes As Variant
Select Case Val(Application.Version)
Case Is >= 16
i1 = "@"
Dim x%, p, l%, s$
For Each p In Interaction.GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery( _
"SELECT name FROM SoftwareLicensingProduct where name like '%office%'", , 48)
s = p.Name
For x = 15 To Len(s)
If Mid$(s, x, 1) Like "#" Then
l = l + 1
Else
If l = 3 Or l = 4 Then
v = CLng(Mid$(s, x - l, l)):
If v = 365 Or v >= 2021 Then i2 = "#": n = 1:
GoTo E
End If
l = 0
End If
Next x
Next p
keyPath = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
rootDirectory = "."
Set registryObject = Interaction.GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default:StdRegProv")
registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes
On Error GoTo ErrorExit
For x = 0 To UBound(arrEntryNames)
If InStr(arrEntryNames(x), "365") > 0 Then i2 = "#": n = 1: v = 365: Exit For
If InStr(arrEntryNames(x), "2019") > 0 Then v = 2019: n = -1: Exit For
If InStr(arrEntryNames(x), "2016") > 0 Then v = 2016: n = -1: Exit For
Next x
Case Is = 15: n = -1: v = 2013
Case Is = 14: n = -1: v = 2010 'ProductCode: {91140000-0011-0000-1000-0000000FF1CE} 'CalculationVersion: 145621
Case Is = 12: n = -1: v = 2007
Case Else: i2 = "#": i1 = "@": n = 1: v = 2024
End Select
E:
newVersion = n: OfficeVersion = v: implicitIntersectionOperator = i1: SpillOperator = i2
Exit Function
ErrorExit:
v = 2016: n = -1: OfficeVersion = v: newVersion = n
End Function
giaiphapexcel.com
Việc đánh giá đáng hay không đáng là do cá nhân người ta nhận xét. Bác chả có quyền gì phán xét nhận xét của họ cả.
Cái này dễ còn hơn ăn phở. Gửi file mong muốn lên nhé bạn
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.
Selection.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. 
))Test thử đi bác
Bạn muốn xử lý công thức tại ô nào?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
Tấ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
Chưa xử lý trường hợp round(A1, - 1). Nhưng mà có cơ sở chắc sửa không đến nỗi khó. Để chờ món phở của bác Cháo Quẩy xem như thế nào rồi em sửa sau vậy!Tấ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
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 SubPhở 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....
Cháu thấy ổn đó bác, cháu đanng nghĩ cách dùng lambda mà dùng trực tiếp round.
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' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
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(CVar(ZipFile & "\xl\worksheets\")) Is Nothing
DoEvents: Sleep 20
k = k + 1: If k > 20 Then Exit Do
Loop: k = 0
Do While oSh.Namespace(CVar(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
'> (?:>) < (?:<) & (?:&)
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
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 FunctionVBA 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.
