Sub YahooDictWebQuery()
On Error Resume Next
For x = 1 To Range("A" & Rows.Count).End(xlUp).Row
Dim IE As New InternetExplorer
IE.Visible = True
IE.navigate "http://hk.dictionary.yahoo.com/dictionary?p=" & Cells(x, 1).Value
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Dim Doc As HTMLDocument
Set Doc = IE.document
    Cells(x, 3).Value = WorksheetFunction.Substitute(WorksheetFunction.Substitute(WorksheetFunction.Substitute(Right(Doc.getElementsByClassName("pronunciation")(0).getElementsByTagName("div")(0).innerText, WorksheetFunction.Search("DJ", Doc.getElementsByClassName("pronunciation")(0).getElementsByTagName("div")(0).innerText) - 1), "DJ", ""), "[", ""), "]", "")
    Cells(x, 4).Value = Left(Doc.getElementsByClassName("caption")(0).innerText, WorksheetFunction.Search(".", Doc.getElementsByClassName("caption")(0).innerText))
    Cells(x, 5).Value = WorksheetFunction.Substitute(Doc.getElementsByClassName("description")(0).innerText, "1. ", "")
Next x
IE.Quit
On Error GoTo 0
End Sub

Sub CopyVocabListToWord()


On Error Resume Next

Dim formLevel As String
formLevel = InputBox("The Form the Vocabulary List is being made for:" & vbNewLine & _
"e.g. For Form 3, type '3'", "Class Level")

Dim VocabListTitle As String
VocabListTitle = InputBox("Enter the title of this Vocabulary List:" & vbNewLine & _
"e.g. Unit n    Textbook Topic (p.P-P)" _
, "Document Title")

Dim VocabListName As String
ActiveSheet.Name = VocabListName

Dim wrdApp As Word.Application
Set wrdApp = CreateObject("Word.Application")

Dim wrdDoc As Word.document
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

Dim wrdTbl As Word.Table
Set wrdTbl = wrdDoc.Tables.Add(Range:=wrdDoc.Range, _
NumRows:=ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 2, _
NumColumns:=4)


With wrdTbl

    .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
    .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
    .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
    .Borders(wdBorderRight).LineStyle = wdLineStyleSingle
    .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
    .Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
    
    For c = 1 To 2
    .Rows(c).Cells.Merge
    Next c
        
For r = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    .Cell(2 * r + 2, 2).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    .Cell(2 * r + 2, 4).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    
    .Range.Font.Name = "Times New Roman"
    .Range.ParagraphFormat.SpaceBefore = 6
    .Range.ParagraphFormat.SpaceAfter = 6
    
If Not r Mod 2 = 0 Then
    .Cell(r + 2, 1).Range.Text = ActiveSheet.Cells(r, 1).Value
    .Cell(r + 2, 2).Range.Text = ActiveSheet.Cells(r, 5).Value
    .Cell(r + 1 + 2, 1).Range.Text = "/" & ActiveSheet.Cells(r, 3).Value & "/"
    .Cell(r + 1 + 2, 2).Range.Text = "(" & ActiveSheet.Cells(r, 2).Value & ")" & " " & "(" & ActiveSheet.Cells(r, 4).Value & ")"
    .Cell(r + 1 + 2, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
End If
If r Mod 2 = 0 Then
    .Cell(r - 1 + 2, 3).Range.Text = ActiveSheet.Cells(r, 1).Value
    .Cell(r - 1 + 2, 4).Range.Text = ActiveSheet.Cells(r, 5).Value
    .Cell(r + 2, 3).Range.Text = "/" & ActiveSheet.Cells(r, 3).Value & "/"
    .Cell(r + 2, 4).Range.Text = "(" & ActiveSheet.Cells(r, 2).Value & ")" & " " & "(" & ActiveSheet.Cells(r, 4).Value & ")"
    .Cell(r + 2, 4).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
End If
Next r


Dim wrdTpl As Word.ListTemplate
Set wrdTpl = wrdApp.ListGalleries(wdNumberGallery).ListTemplates(1)
With wrdTpl.ListLevels(1)
    .NumberFormat = "%1."
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleArabic
    .NumberPosition = wrdApp.CentimetersToPoints(0.1)
    .TextPosition = wrdApp.CentimetersToPoints(0.8)
    .Alignment = wdListLevelAlignLeft
    .TabPosition = wdUndefined
    .StartAt = 1
End With

Dim rng As Word.Range
Set rng = wrdTbl.Range
rng.ListFormat.ApplyListTemplate ListTemplate:=wrdTpl

.Rows(1).Range.ListFormat.RemoveNumbers
For r = 2 To 16 Step 2
    
    .Rows(r).Range.ListFormat.RemoveNumbers
    For c = 2 To 4 Step 2
    .Cell(r - 1, c).Range.ListFormat.RemoveNumbers
    Next c
Next r


For nTxtNum = 1 To 5
.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum - 1)) - 1).Range.Rows.Add
.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum)) - 1).Range.Rows.Add
.Rows(ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum - 1)).Cells.Merge
.Rows(ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 2) + (nTxtNum - 1)).Cells.Merge
.Rows(ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 2) + (nTxtNum - 1)).Range.Text = ActiveSheet.Cells(nTxtNum, 7).Value

.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum))).Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum))).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum))).Borders(wdBorderRight).LineStyle = wdLineStyleNone

.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum - 1))).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Rows((ActiveSheet.Cells(nTxtNum, 8) + (nTxtNum + 1) + (nTxtNum - 1))).Borders(wdBorderRight).LineStyle = wdLineStyleNone

Next nTxtNum

wrdDoc.Range(Start:=.Rows(1).Range.Start, End:=.Rows(2).Range.End).Borders(wdBorderTop).LineStyle = wdLineStyleNone
wrdDoc.Range(Start:=.Rows(1).Range.Start, End:=.Rows(2).Range.End).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
wrdDoc.Range(Start:=.Rows(1).Range.Start, End:=.Rows(2).Range.End).Borders(wdBorderBottom).LineStyle = wdLineStyleNone
wrdDoc.Range(Start:=.Rows(1).Range.Start, End:=.Rows(2).Range.End).Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Rows(1).Range.Borders(wdBorderBottom).LineStyle = wdLineStyleNone

.Rows(1).Range.Text = VocabListTitle
.Rows(2).Range.Text = "Vocabulary"
.Rows(3).Delete

End With

With wrdTbl.Rows(1).Range
    .InsertParagraphBefore
    .InsertBefore ("Class: " & formLevel & "__________                                                              Name: _________________(     )")
End With

With wrdDoc.Sections(1)
    .Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True
End With


MsgBox ("Now, you're going to save the document." & vbNewLine & _
"You may need to manually alter part of the document to suit your needs." & vbNewLine & _
"This VBA application only helps you batch produce a document.")

wrdDoc.Save
Set wrdDoc = Nothing
Set wrdApp = Nothing
On Error GoTo 0
End Sub