Question

我使用了一个宏来遍历单词表中的每个单元格并粘贴到excel中，但是我的一个文档有96页，并且需要40分钟将其全部复制到电子表格中。我发现如果将表转换为文本（以逗号分隔）然后保存为.txt文件，然后导入到电子表格中，它会更快，但我无法弄清楚如何编写宏或vbscript来一次性完成所有操作。任何想法??

Private Sub ImportWordTable()

Dim wddoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Integer
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer

On Error Resume Next

Application.ScreenUpdating = False

ActiveSheet.Range("A:AZ").ClearContents

wdFileName = Application.GetOpenFilename("Word files (*DOC),*.doc", , _
"Browse for file containing table to be imported")

If wdFileName = "" Then Exit Sub

Set wddoc = GetObject(wdFileName)


With wddoc
    tableNo = wddoc.Tables.Count
    tableTot = wddoc.Tables.Count
    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
            tableNo = 1

    End If

    resultRow = 1

    For tableStart = 1 To tableTot
        With .Tables(tableStart)


            For iRow = 1 To .Rows.Count
                For iCol = 1 To .Columns.Count
                   Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                    Cells(resultRow) = WorksheetFunction.Clean(.Cell(iRow).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With

Set wddoc = Nothing

End Sub

Answer 1

试试这个......

Sub ImportWordTable()

Dim wddoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Integer
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer

Application.ScreenUpdating = False
ActiveSheet.Range("A:AZ").ClearContents

wdFileName = Application.GetOpenFilename("Word files (*DOC),*.doc", , _
            "Browse for file containing table to be imported")

If wdFileName = "" Then Exit Sub
Set wddoc = GetObject(wdFileName)

With wddoc
    tableNo = wddoc.Tables.Count
    tableTot = wddoc.Tables.Count

    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = 1
    End If

    For tableStart = 1 To tableTot
        Application.StatusBar = "Processing " & tableStart & "of (" & tableTot & ") Tables"
        .Tables(tableStart).Range.Copy
        resultRow = Range("A" & Rows.Count).End(xlUp).Offset(2).Row
        DoEvents
        On Error Resume Next
        Range("A" & resultRow).PasteSpecial xlPasteValues
        On Error GoTo 0
    Next tableStart
End With

Set wddoc = Nothing
Application.StatusBar = ""

Application.ScreenUpdating = True

End Sub

将.rtf表转换为文本（逗号分隔），然后粘贴到Excel文档中

1 个答案: