Excel VBA loop rows until empty then paste into empty cell - vba

Question

I'm trying to paste a range from Word into Excel.
The macro loops through every Word doc in the directory. Each time it selects a range I'd like it to paste into cell H10, but if cell H10 is not empty I would like it to move down to cell H11 and so on.
My code works if I do this:
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
But how can I refine it so it offsets one cell down each time automatically?

Answer 1

The condition is set wrongly try this
Do Until IsEmpty(ActiveCell)=False
ActiveCell.Offset(1, 0).Select
Loop
ObjWorksheet.Paste
The line
Do Until IsEmpty(ActiveCell)=False
Will select the next cell below one row active cell until it isn't empty

Answer 2

I think ths script below would be MUCh easier to wrk with if you want to import data from tables in multiple Word files.
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