將.rtf表格轉換爲文本（逗號分隔）然後粘貼到excel文檔中

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