Function GetNumeric(t As Range) As Double
'---------------------------------------------------------------------------------------
' Author : HUGO
' Purpose : Извлекает цифры из ячейки
'---------------------------------------------------------------------------------------
Dim J As Integer, l As String
For J = 1 To Len(t)
If IsNumeric(Mid(t, J, 1)) Then l = l & Mid(t, J, 1)
Next J
GetNumeric = Val(l)
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Public Function ExtractNumber(s As String)
Dim i As Integer, str As String, a$
For i = 1 To Len(s)
a = Mid(s, i, 1)
If InStr(1, "1234567890,", a) Then str = str & a
Next
ExtractNumber = str
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Function NumbersOnly(srcStr As String) As String
'---------------------------------------------------------------------------------------
' Purpose : Извлекает цифры из ячейки
'---------------------------------------------------------------------------------------
Dim objRegEx As Object
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.Global = True
.Pattern = "[^0-9,]" '"\D"
NumbersOnly = .Replace(srcStr, vbNullString)
End With
Set objRegEx = Nothing
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Function ИЗВЛЕЧ_ЦИФР(ЯЧЕЙКА As Range) As String
'---------------------------------------------------------------------------------------
' Purpose : Извлекает цифры из ячейки
'---------------------------------------------------------------------------------------
Dim LenStr As Long
For LenStr = 1 To Len(ЯЧЕЙКА)
Select Case Asc(Mid(ЯЧЕЙКА, LenStr, 1))
Case 48 To 57
ИЗВЛЕЧ_ЦИФР = ИЗВЛЕЧ_ЦИФР & Mid(ЯЧЕЙКА, LenStr, 1)
End Select
Next
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Function ИЗВЛЕЧ_БУКВ(ЯЧЕЙКА As Range) As String
'---------------------------------------------------------------------------------------
' Purpose : Извлекает буквы из ячейки
'---------------------------------------------------------------------------------------
Dim LenStr As Long
For LenStr = 1 To Len(ЯЧЕЙКА)
Select Case Asc(Mid(ЯЧЕЙКА, LenStr, 1))
Case 65 To 90, 97 To 122, 192 To 255, 168, 184
ИЗВЛЕЧ_БУКВ = ИЗВЛЕЧ_БУКВ & Mid(ЯЧЕЙКА, LenStr, 1)
End Select
Next
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Function GetNotNumericFromLeft(t As Range) As String
' удаляет все цифры слева
Dim J As Integer
For J = 1 To Len(t)
If Not IsNumeric(Mid(t, J, 1)) Then
If Mid(t, J, 1) <> " " Then GetNotNumericFromLeft = Mid(t, J): Exit Function
End If
Next J
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
'то же самое, что выше, но в профиль :)
Function DelLeftNumeric(txt As String) As String
' удаляет все цифры слева
Dim i&
For i = 1 To Len(txt)
If InStr(" 0123456789", Mid$(txt, i, 1)) = 0 Then Exit For
Next i
DelLeftNumeric = Mid$(txt, i, Len(txt) - i + 1)
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Function Extract_Number_from_Text(sWord As String, Optional Metod As Integer) '0 числа, 1 текст
'---------------------------------------------------------------------------------------
' Module : mNumberFromText
' DateTime : 18.03.2011 15:21
' Author : The_Prist(Щербаков Дмитрий)
' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' www.excel-vba.ru
' Purpose : http://www.planetaexcel.ru/forum.php?thread_id=25683
'---------------------------------------------------------------------------------------
Dim sSymbol As String, sInsertWord As String
Dim i As Integer
If sWord = "" Then Extract_Number_from_Text = "Нет данных!": Exit Function
sInsertWord = ""
sSymbol = ""
For i = 1 To Len(sWord)
sSymbol = Mid(sWord, i, 1)
If Metod = 1 Then
If Not LCase(sSymbol) Like "*[0-9]*" Then
If sSymbol = "," Or sSymbol = "." Or sSymbol = " " Then
If Mid(sWord, i - 1, 1) Like "*[0-9]*" And Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
sSymbol = ""
End If
End If
sInsertWord = sInsertWord & sSymbol
End If
Else
If LCase(sSymbol) Like "*[0-9.,;:-]*" Then
If LCase(sSymbol) Like "*[.,]*" Then
If Not Mid(sWord, i - 1, 1) Like "*[0-9]*" Or Not Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
sSymbol = ""
End If
End If
sInsertWord = sInsertWord & sSymbol
End If
End If
Next i
Extract_Number_from_Text = sInsertWord
End Function
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Function Num(Текст As String) As Long
'---------------------------------------------------------------------------------------
' Purpose : Извлекает цифры из ячейки
'---------------------------------------------------------------------------------------
Dim n
For n = 1 To Len(Текст)
If Mid(Текст, n, 1) Like "#" Then Num = Num & Mid(Текст, n, 1)
Next n
End Function
|