Блог

Я хочу создать функцию, в которой я извлекаю все слова с длиной = 2 из предложения. Например, если предложение «Кошка коричневая», я хочу, чтобы результат в ячейке был «есть». Если есть несколько слов с длиной = 2, я тоже хочу их сохранить. Я пробовал СЕРЕДИНУ, ПРАВУЮ, ЛЕВУЮ и т. Д. Это не работает, так как позиция слова не всегда одинакова.

Я понятия не имею, как это сделать в VBA, любые предложения приветствуются 🙂

Спасибо

Я создал для вас UDF, который должен работать для того, что вы хотите. Вы используете это так:

=ExtractWords(Cell to check, Optional number of letters)

По умолчанию он будет проверять наличие слов из 2 букв, но вы можете указать также, как показано выше.

Вот код. Поместите его в модуль

 Function ExtractWords(Cell As Range, Optional NumOfLetters As Integer)

Dim r As String, i As Long, CurrentString As String, FullString As String, m As String

If NumOfLetters = 0 Then NumOfLetters = 2

r = Cell.Value

For i = 1 To Len(r)
    m = Mid(r, i, 1)
    If Asc(UCase(m)) >= 65 And Asc(UCase(m)) <= 90 Or m = "-" Or m = "'" Then 'Accepts hyphen or single quote as part of the word
        CurrentString = CurrentString amp; m
        If i = Len(r) Then GoTo CheckLastWord
    Else
CheckLastWord:
        If Len(CurrentString) = NumOfLetters Then
            If FullString = "" Then
                FullString = CurrentString
            Else
                FullString = FullString amp; " " amp; CurrentString 'Change space if want another delimiter
            End If
        End If
        CurrentString = ""
    End If
Next i

If FullString = "" Then
    ExtractWords = "N/A" 'If no words are found to contain the length required
Else
    ExtractWords = FullString
End If

End Function
 

Вероятно, есть другие способы сделать это, которые могут быть проще или эффективнее. Это просто то, что я придумал.

Двойные вхождения верхнего регистра

• В Excel вы можете, например, использовать его следующим образом:

   =getDUC(A1)
  =getDUC(A1," ")
  =getDUC(A1,",")
  =getDUC(A1,"-")
   

Код

 Option Explicit

' In Excel:
Function getDUC( _
    ByVal s As String, _
    Optional ByVal Delimiter As String = ", ") _
As String
    Dim arr As Variant
    arr = DoubleUCaseToArray(s)
    getDUC = Join(arr, Delimiter)
End Function

' In VBA:
Sub testDoubleUCaseToArray()
    Dim CCodes As Variant: CCodes = Array("US,UKUs", "UkUS,UK", "kUSUKsUK")
    Dim arr As Variant
    Dim n As Long
    For n = LBound(CCodes) To UBound(CCodes)
        arr = DoubleUCaseToArray(CCodes(n))
        Debug.Print Join(arr, ",")
    Next n
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      From a specified string, returns all unique double upper case
'               occurrences in a 1D (zero-based) array.
' Remarks:      From the string 'USUk' it returns only 'US' (not `SU`).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DoubleUCaseToArray( _
    ByVal s As String) _
As Variant
    If Len(s) > 1 Then
        With CreateObject("Scripting.Dictionary")
            Dim cFirst As String * 1
            Dim cSecond As String * 1
            Dim n As Long
            For n = 1 To Len(s) - 1
                cFirst = Mid(s, n, 1)
                If cFirst Like "[A-Z]" Then
                    cSecond = Mid(s, n   1, 1)
                    If cSecond Like "[A-Z]" Then
                        .Item(cFirst amp; cSecond) = Empty
                    End If
                    n = n   1
                End If
            Next n
            If .Count > 0 Then
                DoubleUCaseToArray = .Keys
            End If
        End With
    End If
End Function