Страницы: 1
RSS
Извлечение числовых значений из ячейки, где есть и числа и буквы
 
Доброй ночи!

Такой вопрос:
допустим, у нас есть столбец со следующими данными:
abc123
cds321
St7782dar
675fdjsf12
dewqrjw1

Каких-то закономерной расположения цифр и букв нет. Как можно вытащить только цифры из данного массива?  
 
UDF делает это легко. Формулами не знаю.. заменить что ли все буквы на ничего?
 
Как вариант - да. А как это сделать с UDF?  
 
Вот всякие, выбирайте что больше нравится (и извлечение букв тоже):
Код
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

Спрятать под спойлер не получается...
Изменено: Hugo - 31.03.2015 19:47:30
 
Тут есть решение формулой от _Boroda_, пост №3
Изменено: Sanja - 31.03.2015 10:13:57
Согласие есть продукт при полном непротивлении сторон
 
Ну и в добавок регулярка Александра ikki
Код
Function ikki$(s$)

Static r As Object: If r Is Nothing Then Set r = CreateObject("vbscript.regexp"):
r.Global = 1:
r.IgnoreCase = True
r.Pattern = "[^0-9]+"
ikki = r.Replace(s, "")
End Function
Лень двигатель прогресса, доказано!!!
 
Немного сократил формулу _Boroda_ за счет применения Имени для части формулы
Согласие есть продукт при полном непротивлении сторон
 
Как-то так. Возвращает подстроку из содержащихся в строке числовых символов (подразумевается, что дробной части нет)
Код
Function ДостатьЧисло(Строка As String) As String
Dim L As Long, S As String
L = Len(Строка)
If L = 0 Then Exit Function
For I = 1 To L
S = Mid(Строка, I, 1)
If InStr("0123456789", S) <> 0 Then ДостатьЧисло = ДостатьЧисло & S
Next I
End Function

 
Уже давно пользуюсь UDF-ками для работы с текстами там, где обычные экселевские формулы не могут работать или работают после сложных формул.
Вот простенькая UDF для замены с использованием регулярки:
Код
Function defRegExReplace(strInput As String, strPattern As String, Optional strReplace As String = "") As String
    Dim regEx As Object
    
    Set regEx = CreateObject("VBScript.RegExp")
    If strPattern = "" Then defRegExReplace = strInput: set regEx = Nothing: Exit Function
    
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern
    End With

    If regEx.test(strInput) Then
        defRegExReplace = regEx.Replace(strInput, strReplace)
    Else
        defRegExReplace = strInput
    End If
    set regEx = Nothing
    
End Function
А вот и формула, которая используется в соседней ячейке:
Код
=defRegExReplace(A1;"\D*")
UDF можно немного оптимизировать через введение статичной переменной, но это уже другая история.
Изменено: Все_просто - 31.03.2015 11:45:55 (видоизменил код)
С уважением,
Федор/Все_просто
 
Формула массива:
=СУММ(ПСТР(0&A1;НАИБОЛЬШИЙ(НЕ(ЕОШ(ПСТР(A1;СТРОКА($1:$99);1)*1))*СТРОКА($1:$99);СТРОКА($1:$15))+1;1)*10^(СТРОКА($1:$15)-1))
 
14 решений задачи за 1 час 20 мин создатель темы походу не смог переварить и ушел в астрал :D
Лень двигатель прогресса, доказано!!!
 
жалко что это не работает:
Код
=ЗАМЕНИТЬ(A1;ЕСЛИ(НЕ(ЕЧИСЛО(--ПСТР(A1;СТРОКА($1:$20);1)));СТРОКА($1:$20);0);1;)
F1 творит чудеса
Страницы: 1
Наверх