Question

我正试图从具有许多外语单词的一列“ A1”中提取英语词典单词到另一列“ B1”。我想一次在整个专栏中进行此操作。我有找到的宏，但是它仅对一个单元格起作用，而不是一次对整个列起作用。宏是：

Sub ExtractDictionaryWords()
    Dim rWords As Range
    Dim rCell As Range

    Application.ScreenUpdating = False
    Set rWords = Range(Range("A1"), _
      Range("A65536").End(xlUp))
    For Each rCell In rWords
        If Not Application.CheckSpelling(rCell.Value) Then
            rCell.Clear
        End If
    Next
    On Error Resume Next
    rWords.SpecialCells(xlCellTypeBlanks). _
      Delete (xlShiftUp)
    On Error GoTo 0
    Set rCell = Nothing
    Set rWords = Nothing
    Application.ScreenUpdating = True
End Sub

数据为：

"A1"
abro
abroad
abroahsan
abroc
abrod
abrogated
abrogreat
abrunt
abrupt
abruptly
abruti
abrutis
abs
absa

所需的列是通过在整个列范围内一次使用宏来实现的：

"A1"                     "B1"
abro                       
                        abroad
abroahsan
abroc
abrod
                        abrogated
abrogreat
                        abrunt
                        abrupt
                        abruptly
abruti
abrutis
abs
absa
zzz
ziyyyyy

Answer 1

尝试以下方法进行转换。您将需要循环。拼写检查是循环执行的。

Option Explicit
Public Sub ExtractDictionaryWords()
    Dim rWords As Range, rCell As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        Set rWords = .Range(.Range("A1"), _
                            .Range("A65536").End(xlUp))
        For Each rCell In rWords
            If Application.CheckSpelling(rCell.Value) Then
                rCell.Copy rCell.Offset(, 1)
                rCell.Clear
            End If
        Next
       ' On Error Resume Next
       ' rWords.SpecialCells(xlCellTypeBlanks). _
        Delete (xlShiftUp)
       ' .Range(.Range("B1"), _
               .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeBlanks). _
                                                        Delete (xlShiftUp)
       ' On Error GoTo 0
    End With
    Application.ScreenUpdating = True
End Sub

一种更有效的方法是使用Union一次性移动并一次性清除单元格。此版本基于以前删除空白单元格的事实。对于显示的输出，请使用以上版本。

Option Explicit
Public Sub ExtractDictionaryWords()
    Dim rWords As Range, rCell As Range, englishSpellings As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        Set rWords = .Range(.Range("A1"), _
                            .Range("A65536").End(xlUp))
        For Each rCell In rWords
            If Application.CheckSpelling(rCell.Value) Then
                If Not englishSpellings Is Nothing Then
                    Set englishSpellings = Union(englishSpellings, rCell)
                Else
                    Set englishSpellings = rCell
                End If
            End If
        Next
        If Not englishSpellings Is Nothing Then
            englishSpellings.Copy .Range("B1")
            englishSpellings.Clear
        Else
            Exit Sub
        End If
        On Error Resume Next
        rWords.SpecialCells(xlCellTypeBlanks). _
        Delete (xlShiftUp)
        .Range(.Range("B1"), _
               .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeBlanks). _
                                                        Delete (xlShiftUp)
        On Error GoTo 0
    End With
    Application.ScreenUpdating = True
End Sub

在Excel中使用Macro提取英语词典单词

1 个答案: