时间戳

首页 > 解决方案 > 在excel中使用宏提取英语词典单词

excel - 在excel中使用宏提取英语词典单词

问题描述

我正在尝试从具有许多外语单词的一列“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

标签： excelvba

解决方案

尝试以下方法来进行转变。您将需要循环。拼写检查在循环中执行。

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

推荐阅读