Excel Program 1

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



1 view0 comments

Recent Posts

See All