在Excel VBA中剥离大写单词

Question

Stripping Uppercase Words in Excel VBA

I have an Excel sheet like this one:

A        B
1        Used CONTENT VERSION SYSTEM for the FALCON Project
2        USA beats UK at Soccer Cup 2008
3        DARPA NET’s biggest contribution was the internet
4        One big problem is STRUCTURED QUERY LANGUAGE queries on non-normalized data

I want to extract all of the words in UPPERCASE and generate a list with them:

A                             B
CONTENT VERSION SYSTEM        1
FALCON                        1
USA                           2
UK                            2
DARPA NET                     3
STRUCTURED QUERY LANGUAGE     4

I was thinking that I could check if “eachWord” == UCase(eachWord), but I don't know how to handle phrases. I also don't know how to handle phrases that end in “apostrophe s”, “end parenthesis”, or punctuation.

I've been splitting words like this: IndividualWordsArray = Split(ActiveSheet.Cells(workingRow, 2).Value)

But that only makes an array based on space chars. I thought it might help if, in addition to spaces, it could also split by these chars: “ ( ) : ' , . ? ! ; After some searching, I find I can split a line by a char other than spaces, but only one delimiter at a time.

Anyone have any idea how to create a list with all of the uppercase words and phrases?

Answer 1

一种简单的方法是获取文本副本，将所有定界符替换为空格字符，然后使用空格作为定界符进行分割。

Answer 2

Here's an ugly slow way, but it does work (except it won't return NET from NET's). I just loop through the array of words and test each letter for caps. The Option Compare Binary statement is crucial.

Option Explicit
Option Compare Binary

Sub x()
    Dim IndividualWordsArray() As String, keeperArray() As String
    Dim i As Integer, j As Integer, k As Integer
    Dim allCaps As Boolean

    IndividualWordsArray = Split(ActiveCell)
    k = 0
    For i = 0 To UBound(IndividualWordsArray)
        allCaps = True
        For j = 1 To Len(IndividualWordsArray(i))
            If Not Mid(IndividualWordsArray(i), j, 1) Like "[A-Z]" Then
                allCaps = False
                Exit For
            End If
        Next j
        If allCaps Then
            ReDim Preserve keeperArray(k)
            keeperArray(k) = IndividualWordsArray(i)
            Debug.Print keeperArray(k)
            k = k + 1
        End If
    Next i
End Sub