Question

我尝试将Word中的范围粘贴到Excel中。宏循环遍历目录中的每个Word文档。每次选择一个范围我都希望它粘贴到单元格H10中，但如果单元格H10不为空，我希望它向下移动到单元格H11，依此类推。

如果我这样做，我的代码就可以了：

Dim rng1 As Range
Dim rng2 As Range
Dim oDoc As Document
Dim oExcel As Object, oWB As Object, ObjWorksheet As Object

...

oDoc.Range(rng1.End, rng2.Start).Select
    ' select from the end of range 1 to the start of range 2 (after name but before keywords)
    Selection.Copy
    ' copy the selection

    ObjWorksheet.Range("H10").Select
    If IsEmpty(ObjWorksheet.Range("H10")) = True Then
    ObjWorksheet.Paste
    Else: ObjWorksheet.Range("H10").Offset(1, 0).Select
        If IsEmpty(ObjWorksheet.Range("H10").Offset(1, 0)) = True Then
        ObjWorksheet.Paste
            Else: ObjWorksheet.Range("H10").Offset(2, 0).Select
                If IsEmpty(ObjWorksheet.Range("H10").Offset(2, 0)) = True Then
                ObjWorksheet.Paste
                    Else: ObjWorksheet.Range("H10").Offset(3, 0).Select
                        If IsEmpty(ObjWorksheet.Range("H10").Offset(3, 0)) = True Then
                        ObjWorksheet.Paste
                            Else: ObjWorksheet.Range("H10").Offset(4, 0).Select
                                If IsEmpty(ObjWorksheet.Range("H10").Offset(4, 0)) = True Then
                                ObjWorksheet.Paste
                                    Else: ObjWorksheet.Paste
                                End If
                        End If
                End If
        End If
    End If

但是如何对其进行优化以使其每次自动抵消一个单元格呢？

Answer 1

条件设置错误尝试此

Do Until IsEmpty(ActiveCell)=False
ActiveCell.Offset(1, 0).Select
Loop

ObjWorksheet.Paste

该行

  Do Until IsEmpty(ActiveCell)=False

将选择一行活动单元格下方的下一个单元格，直到它不为空

Answer 2

如果您想从多个Word文件中的表中导入数据，我认为下面的脚本将更容易使用。

Sub WordToExcel()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim x As Integer
Dim strFilename As String
Dim strFolder As String
Dim temp As String

Set wdApp = New Word.Application
'initialise counter
x = 1
'search for first file in directory
strFolder = "C:\Test\"
strFilename = Dir(strFolder & "*.doc")
'amemd folder name
Do While strFilename <> ""
Set wdDoc = wdApp.Documents.Open(strFolder & strFilename)
temp = wdDoc.Tables(1).Cell(2, 1).Range.Text 'read word cell
Range("A2").Offset(x, 0) = temp
temp = wdDoc.Tables(1).Cell(2, 2).Range.Text 'read word cell
Range("A2").Offset(x, 1) = temp
'etc
temp = wdDoc.Tables(1).Cell(2, 3).Range.Text 'read word cell
Range("A2").Offset(x, 2) = temp
temp = wdDoc.Tables(1).Cell(2, 4).Range.Text 'read word cell
Range("A2").Offset(x, 3) = temp

wdDoc.Close
x = x + 1
strFilename = Dir
Loop
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub

Excel VBA循环行直到空，然后粘贴到空单元格

2 个答案: