Sub ChangeToValue()
Dim rng As Range
With ActiveSheet
For Each rng In .UsedRange
rng.Value = rng.Value
Next rng
End With
End Sub
Sub DocFormulasWks()
Dim rng As Range
With ActiveSheet
For Each rng In .UsedRange
If rng.HasFormula = True Then
Debug.Print "Addr.:" & rng.Address
Debug.Print "Form.:" & rng.Formula
Debug.Print "Value:" & rng.Value
End If
Next rng
End With
End Sub
Sub docFormulasWkb()
Dim rng As Range
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
For Each rng In wks.UsedRange
If rng.HasFormula = True Then
Debug.Print "Sheet:" & wks.Name
Debug.Print "Address:"&rng.Address
Debug.Print "Formula:"&rng.Formula
Debug.Print "Value:" & rng.Value
End If
Next rng
Next wks
End Sub
Sub DeleteExLinks()
Dim rng As Range
With ActiveSheet
For Each rng In .UsedRange
If InStr(rng.Formula, "[") > 0 Then
rng.Value = rng.Value
End If
Next rng
End With
End Sub
Sub DeleteExLinksWkb()
Dim rng As Range
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
For Each rng In wks.UsedRange
If InStr(rng.Formula, "[") > 0 Then
rng.Value = rng.Value
End If
Next rng
Next wks
End Sub
Sub NewSheetWithFormulas()
Dim rng As Range
Dim wks As Worksheet
Dim i As Integer
With Sheets("Documentation")
i=1
For Each wks In _
ActiveWorkbook.Worksheets
For Each rng In wks.UsedRange
If rng.HasFormula = True Then
.Cells(i, 1).Value = wks.Name
.Cells(i, 2).Value = rng.Address
.Cells(i, 3).Value=""& rng.Formula
.Cells(i, 4).Value = rng.Value
i = i+1
End If
Next rng
Next wks
End With
End Sub
Function WkbName()
WkbName = ActiveWorkbook.Name
End Function
Function WkbPath()
WkbPath = ActiveWorkbook.Path
End Function
Function WkbFull()
WkbFull = ActiveWorkbook.FullName
End Function
Function ExcelUser()
ExcelUser = Application.UserName
End Function
Function FormT(rng As Range)
FormT = " " & rng.Formula
End Function
Function FormYes(rng As Range)
FormYes = rng.HasFormula
End Function
Function Valid(rng As Range)
Dim intV As Integer
On Error GoTo errorM
intV = rng.Validation.Type
Valid = True
Exit Function
errorM:
Valid = False
End Function
Function ComT(rng As Range)
On Error GoTo errorM
If Len(rng.Comment.Text) > 0 Then _
ComT = True
Exit Function
errorM:
ComT = False
End Function
Function SumColor(Area As Range, Ci As Integer)
Dim sng As Single, rng As Range
For Each rng In Area
If rng.Interior.ColorIndex = Ci Then sng =
sng+rng.Value
Next rng
SumColor = sng
End Function
Function SumColorF(Area As Range, Ci As Integer)
Dim sng As Single, rng As Range
For Each rng In Area
If rng.Font.ColorIndex = Ci Then sng =
sng+rng.Value
Next rng
SumColorF = sng
End Function
Function KillZeros(rng As Range)
Dim intS As Integer
intS = rng
While intS - Int(intS) > 0
intS = intS * 10
Wend
KillZeros = intS
End Function
Function LetterOut(rng As Range)
Dim i As Integer
For i = 1 To Len(rng)
Select Case Asc (Mid(rng.Value, i, 1))
Case 0 To 64, 123 To 197
LetterOut = LetterOut & Mid(rng.Value, i, 1)
End Select
Next i
End Function
Function NumberOut(rng As Range)
Dim i As Integer
For i = 1 To Len(rng)
Select Case Asc (Mid(rng.Value, i, 1))
Case 0 To 64, 123 To 197
Case Else
NumberOut = NumberOut & _
Mid(rng.Value, i, 1)
End Select
Next i
End Function
Function FirstNum(rng As Range)
Dim i As Integer
For i = 1 To Len(rng.Value)
Select Case Mid(rng.Value, i, 1)
Case 0 To 9
FirstNum = i
Exit Function
End Select
Next i
End Function
Function Qs(rng As Range)
Dim i As Integer
For i = 1 To Len(rng.Value)
Qs = Qs+Cint (Mid(rng.Value, i, 1))
Next i
End Function
Function QsE(Area As Range)
Dim i As Integer
Dim rng As Range
For Each rng In Area
For i = 1 To Len(rng.Value)
QsE = QsE+CInt (Mid(rng.Value, i, 1))
Next i
Next rng
End Function
Function ShEmpty(s As String) As Boolean
If Application.CountA (Sheets(s).UsedRange) = 0
Then
ShEmpty = True
Else
ShEmpty = False
End If
End Function
Function ShProt(s As String) As Boolean
On Error GoTo errorM
If Sheets(s).ProtectContents = True Then
ShProt = True
End If
Exit Function
errorM:
ShProt = False
End Function
Function AuTxt(rng As Range) As String
Select Case rng.Value
Case 1
AuTxt = "fire"
Case 2
AuTxt = "water"
Case 3
AuTxt = "heaven"
Case Else
AuTxt = "invalid text"
End Select
End Function
Comments