从 Excel table 填充单词 tables
Populate word tables from an Excel table
从我们的审计数据库中，我得出如下所示的 Excel table。我需要做的是用 excel table 中第一行的内容填充 word 模板文档中的 table，然后删除几行并有一个新的 table 与第一个相同，但填充了 excel table 中第二行的内容，依此类推，直到到达 Excel table 的末尾].
我知道如何使用 Word 书签从 Excel 填充一个 Word table，但我不确定如何进行这种循环，并在每个 table 之后删除行.
任何让我走上正轨的提示都将不胜感激。
我目前编写的代码如下，它虽然复制了书签中的整个 table，但没有像我希望的那样将每一行都复制到一个单独的 table 中。
'Starting to generate the report in MsWord
Sheets("Data Table").Select
Set wdApp = New Word.Application
uName = Environ("Username")
fName = "C:\Users\" & uName & "\Form Templates\Custom Reports\Draft
Report Template\Template.dotx"
With wdApp
.Visible = True
'.Activate
.Documents.Open fName, , ReadOnly
Sheets("Main Body of the Report").Select
Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Range("D4:" & "E" & ActiveCell.Row).Select 'main body of the report
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "MainBody"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
With .Selection.Find
.Text = "Observations: "
.Replacement.Text = "Observations:^t^t^t^t^t^t^t^t^t"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
我自己有 self-resolved 问题。也许不是我最初想要的方式，但它有效并且满足了我们的需求。下面是完整代码。我最终在 Excel 中生成了表格，并将它们复制到 word 中并进行了一些格式化。
Sub RefreshData_Click()
Dim pvtTbl As PivotTable, aCell As String, rng As String, Cell As Range, vSortList As Variant, PT As PivotTable, wdApp As Word.Application, fName As String, uName As String, StartCell As Range, myList As Range, Y As Range, X As Range
'Data refresh based on project code
ActiveWorkbook.RefreshAll
'Generating various pivot tables with lists of recommendations, annex II, annex of low risk issues, main body of the report
Sheets("Main Body of the Report").Select
Range("D1").Select
Selection.End(xlDown).Select
Range("A1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("A4:A" & rNumber)
For Each X In myList
If X.Font.Bold = True Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 11) = "Background:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
With Range("D" & ActiveCell.Row)
.Characters(Start:=1, Length:=11).Font.Bold = True
End With
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 14) = "Residual risk:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
Range("D" & ActiveCell.Row).Font.Bold = True
Range("D" & ActiveCell.Row).Cells.HorizontalAlignment = xlHAlignJustify
Range("D" & ActiveCell.Row).Value = "Observations: " & Range("D" & ActiveCell.Row).Value
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 12) = "Observation:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
ActiveCell.Replace What:="Observation: ", Replacement:=""
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 7) = "Impact:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
With ActiveCell.Characters(Start:=1, Length:=7)
.Font.Bold = True
End With
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 6) = "Cause:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Bold = True
End With
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 15) = "Recommendation:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
ActiveCell.Replace What:="Recommendation: ", Replacement:="Recommendations:" & Chr(10) & Chr(10)
ActiveCell.Font.Bold = True
ActiveCell.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 9) = "Priority:" Then
X.Select
X.Copy
Range("E" & ActiveCell.Row - 1).Select
ActiveSheet.Paste
ActiveCell.Replace What:="Priority: ", Replacement:="Priority:" & Chr(10) & Chr(10)
ActiveCell.Font.Bold = True
ActiveCell.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
ActiveCell.HorizontalAlignment = xlCenter
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("D4:D" & rNumber)
For Each X In myList
If X.Value = "" Then
X.Select
Range(X.Address & ":E" & ActiveCell.Row).Delete Shift:=xlUp
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("D4:D" & rNumber)
For Each X In myList
If X.Value = "" Then
X.Select
Range(X.Address & ":E" & ActiveCell.Row).Delete Shift:=xlUp
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("D4:D" & rNumber)
For Each X In myList
If Left(X, 17) = "Recommendations:" & Chr(10) Then
X.Select
If Left(Range("D" & ActiveCell.Row + 1).Value, 17) = "Recommendations:" & Chr(10) Then
Range("D" & ActiveCell.Row + 1).Value = Mid(Range("D" & ActiveCell.Row + 1).Value, 19, Len(Range("D" & ActiveCell.Row + 1).Value) - 18)
End If
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("E4:E" & rNumber)
For Each X In myList
If Left(X, 10) = "Priority:" & Chr(10) Then
X.Select
If Left(Range("E" & ActiveCell.Row + 1).Value, 10) = "Priority:" & Chr(10) Then
Range("E" & ActiveCell.Row + 1).Value = Mid(Range("E" & ActiveCell.Row + 1).Value, 12, Len(Range("E" & ActiveCell.Row + 1).Value) - 11)
Range("D" & ActiveCell.Row + 2 & ":E" & ActiveCell.Row + 2).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("D" & ActiveCell.Row).Value = "Management Response"
Range("D" & ActiveCell.Row).HorizontalAlignment = xlCenter
Range("D" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("D" & ActiveCell.Row).Interior.Color = 14277081
Range("D" & ActiveCell.Row).Font.Bold = True
Range("E" & ActiveCell.Row).Value = "Target Implementation Date"
Range("E" & ActiveCell.Row).HorizontalAlignment = xlCenter
Range("E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("E" & ActiveCell.Row).Interior.Color = 14277081
Range("E" & ActiveCell.Row).Font.Bold = True
Range("D" & ActiveCell.Row + 1 & ":E" & ActiveCell.Row + 1).Select
Selection.Insert Shift:=xlDown
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Next
Sheets("Annex II").Select
Range("C4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Ineffective"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Effective"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("D4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""High"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Low"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Moderate"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'Starting to generate the report in MsWord
Sheets("Data Table").Select
Set wdApp = New Word.Application
uName = Environ("Username")
fName = "C:\Users\" & uName & "\World Health Organization\IOS Internal Audit - Form Templates\TeamMate Custom Reports\Draft Report Template\IOS Excel Utility\IOS Template.dotx"
With wdApp
.Visible = True
.Documents.Open fName, , ReadOnly
Range("A2").Copy 'audit code
.Selection.Goto wdGoToBookmark, , , "AuditCodeP1"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeP2"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAI"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAIII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAIV"
.Selection.PasteSpecial , , , , wdPasteText
Range("C6").Copy 'audit title
.Selection.Goto wdGoToBookmark, , , "AuditTitleP1"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleP2"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAI"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAIII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAIV"
.Selection.PasteSpecial , , , , wdPasteText
If Len(Range("H6")) > 0 Then
Range("H6").Copy 'executive summary
.Selection.Goto wdGoToBookmark, , , "ExecutiveSummary"
.Selection.PasteSpecial , , , , wdPasteText
End If
Sheets("Table of Recommendations").Select
Range("A3").Select 'table of recommendations
Range(Selection, Selection.End(xlToRight)).Select 'table of recommendations
Range(Selection, Selection.End(xlDown)).Select 'table of recommendations
Application.CutCopyMode = False
Selection.Copy
Range("H3").Select
ActiveSheet.Paste
Selection.Columns.AutoFit
Application.CutCopyMode = False
'merging and centering the bold lines
Range("H4").Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 5)).Select
Range(Selection, Selection.End(xlDown)).Select
Set StartCell = Range("H4")
Set myList = Range("H4:H" & Range("H" & Rows.Count).End(xlUp).Row)
For Each X In myList
If X.Font.Bold = True Then
X.Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 5)).Merge
End If
Next
Range("H3").Select 'table of recommendations into the word document.
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="(blank)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "TableOfRecommendations"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows(1).Select
.Selection.Rows.HeadingFormat = True
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
Range("H3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Sheets("Data Table").Select
If Len(Range("G6")) > 0 Then
Range("G6").Copy 'introduction
.Selection.Goto wdGoToBookmark, , , "Introduction"
.Selection.PasteSpecial , , , , wdPasteText
End If
If Len(Range("F6")) > 0 Then
Range("F6").Copy 'objective, scope, and approach
.Selection.Goto wdGoToBookmark, , , "ObjectiveScopeApproach"
.Selection.PasteSpecial , , , , wdPasteText
End If
If Len(Range("I6")) > 0 Then
Range("I6").Copy 'audit conclusion
.Selection.Goto wdGoToBookmark, , , "AuditConclusion"
.Selection.PasteSpecial , , , , wdPasteText
End If
If Len(Range("H6")) > 0 Then
Range("I6").Copy 'good practices
.Selection.Goto wdGoToBookmark, , , "GoodPractices"
.Selection.PasteSpecial , , , , wdPasteText
End If
Sheets("Annex II").Select
Range("A3").Select 'annex II
Range(Selection, Selection.End(xlToRight)).Select 'annex II
Range(Selection, Selection.End(xlDown)).Select 'annex II
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "AnnexII"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows(1).Select
.Selection.Rows.HeadingFormat = True
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
Sheets("Annex of Low Risk Recs").Select
Range("A3").Select 'Annex of Low Risk Recs
Range(Selection, Selection.End(xlToRight)).Select 'Annex of Low Risk Recs
Range(Selection, Selection.End(xlDown)).Select 'Annex of Low Risk Recs
Application.CutCopyMode = False
Selection.Copy
Range("D3").Select
ActiveSheet.Paste
Selection.Columns.AutoFit
Application.CutCopyMode = False
'merging and centering the bold lines
Range("D3").Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Select
Range(Selection, Selection.End(xlDown)).Select
Set StartCell = Range("D4")
Set myList = Range("D4:D" & Range("D" & Rows.Count).End(xlUp).Row)
For Each Y In myList
If Y.Font.Bold = True Then
Y.Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Merge
End If
Next
Range("D3").Select 'Annex of Low Risk Recs
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="(blank)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "AnnexIII"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows(1).Select
.Selection.Rows.HeadingFormat = True
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Sheets("Main Body of the Report").Select
Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Range("D4:" & "E" & ActiveCell.Row).Select 'main body of the report
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "MainBody"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
With .Selection.Find
.Text = "Observations: "
.Replacement.Text = "Observations:^t^t^t^t^t^t^t^t^t"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
Sheets("Main Body of the Report").Select
Columns("D:E").Select
Selection.Clear
'Start from the top of the document
wdApp.Selection.HomeKey wdStory
sFindText = "|H1|"
wdApp.Selection.Find.Execute sFindText
Do Until wdApp.Selection.Find.Found = False
wdApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
wdApp.Selection.Style = ActiveDocument.Styles("Heading 1")
wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wdApp.Selection.ParagraphFormat.Space1
wdApp.Selection.ParagraphFormat.SpaceBefore = 12
wdApp.Selection.MoveRight
wdApp.Selection.Find.Execute
Loop
wdApp.Selection.HomeKey wdStory
sFindText = "|H2|"
wdApp.Selection.Find.Execute sFindText
Do Until wdApp.Selection.Find.Found = False
wdApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
wdApp.Selection.Style = ActiveDocument.Styles("Heading 2")
wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wdApp.Selection.ParagraphFormat.Space1
wdApp.Selection.ParagraphFormat.SpaceAfter = 12
wdApp.Selection.ParagraphFormat.SpaceBefore = 12
wdApp.Selection.MoveRight
wdApp.Selection.Find.Execute
Loop
wdApp.Selection.HomeKey wdStory
wdApp.Selection.Find.ClearFormatting
wdApp.Selection.Find.Replacement.ClearFormatting
With wdApp.Selection.Find
.Text = "|H1|"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute Replace:=wdReplaceAll
With wdApp.Selection.Find
.Text = "|H2|"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute Replace:=wdReplaceAll
End With
For Each sht In Application.Worksheets
sht.Sort.SortFields.Clear
Next sht
Set xlApp = Excel.Application
With xlApp
.Visible = True
Sheets("Data Table").Select
Range("A2").Select
MsgBox "Report generated corectly in Ms Word. You may now close the Excel file.", vbOKOnly, "Good news!"
End With
End Sub
从我们的审计数据库中，我得出如下所示的 Excel table。我需要做的是用 excel table 中第一行的内容填充 word 模板文档中的 table，然后删除几行并有一个新的 table 与第一个相同，但填充了 excel table 中第二行的内容，依此类推，直到到达 Excel table 的末尾].
我知道如何使用 Word 书签从 Excel 填充一个 Word table，但我不确定如何进行这种循环，并在每个 table 之后删除行.
任何让我走上正轨的提示都将不胜感激。
我目前编写的代码如下，它虽然复制了书签中的整个 table，但没有像我希望的那样将每一行都复制到一个单独的 table 中。
'Starting to generate the report in MsWord
Sheets("Data Table").Select
Set wdApp = New Word.Application
uName = Environ("Username")
fName = "C:\Users\" & uName & "\Form Templates\Custom Reports\Draft
Report Template\Template.dotx"
With wdApp
.Visible = True
'.Activate
.Documents.Open fName, , ReadOnly
Sheets("Main Body of the Report").Select
Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Range("D4:" & "E" & ActiveCell.Row).Select 'main body of the report
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "MainBody"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
With .Selection.Find
.Text = "Observations: "
.Replacement.Text = "Observations:^t^t^t^t^t^t^t^t^t"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
我自己有 self-resolved 问题。也许不是我最初想要的方式，但它有效并且满足了我们的需求。下面是完整代码。我最终在 Excel 中生成了表格，并将它们复制到 word 中并进行了一些格式化。
Sub RefreshData_Click()
Dim pvtTbl As PivotTable, aCell As String, rng As String, Cell As Range, vSortList As Variant, PT As PivotTable, wdApp As Word.Application, fName As String, uName As String, StartCell As Range, myList As Range, Y As Range, X As Range
'Data refresh based on project code
ActiveWorkbook.RefreshAll
'Generating various pivot tables with lists of recommendations, annex II, annex of low risk issues, main body of the report
Sheets("Main Body of the Report").Select
Range("D1").Select
Selection.End(xlDown).Select
Range("A1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("A4:A" & rNumber)
For Each X In myList
If X.Font.Bold = True Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 11) = "Background:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
With Range("D" & ActiveCell.Row)
.Characters(Start:=1, Length:=11).Font.Bold = True
End With
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 14) = "Residual risk:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
Range("D" & ActiveCell.Row).Font.Bold = True
Range("D" & ActiveCell.Row).Cells.HorizontalAlignment = xlHAlignJustify
Range("D" & ActiveCell.Row).Value = "Observations: " & Range("D" & ActiveCell.Row).Value
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 12) = "Observation:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
ActiveCell.Replace What:="Observation: ", Replacement:=""
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 7) = "Impact:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
With ActiveCell.Characters(Start:=1, Length:=7)
.Font.Bold = True
End With
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 6) = "Cause:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Bold = True
End With
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 15) = "Recommendation:" Then
X.Select
X.Copy
Range("D" & ActiveCell.Row).Select
ActiveSheet.Paste
ActiveCell.Replace What:="Recommendation: ", Replacement:="Recommendations:" & Chr(10) & Chr(10)
ActiveCell.Font.Bold = True
ActiveCell.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("A" & ActiveCell.Row).Select
End If
Next
For Each X In myList
If Left(X, 9) = "Priority:" Then
X.Select
X.Copy
Range("E" & ActiveCell.Row - 1).Select
ActiveSheet.Paste
ActiveCell.Replace What:="Priority: ", Replacement:="Priority:" & Chr(10) & Chr(10)
ActiveCell.Font.Bold = True
ActiveCell.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
ActiveCell.HorizontalAlignment = xlCenter
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("D4:D" & rNumber)
For Each X In myList
If X.Value = "" Then
X.Select
Range(X.Address & ":E" & ActiveCell.Row).Delete Shift:=xlUp
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("D4:D" & rNumber)
For Each X In myList
If X.Value = "" Then
X.Select
Range(X.Address & ":E" & ActiveCell.Row).Delete Shift:=xlUp
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("D4:D" & rNumber)
For Each X In myList
If Left(X, 17) = "Recommendations:" & Chr(10) Then
X.Select
If Left(Range("D" & ActiveCell.Row + 1).Value, 17) = "Recommendations:" & Chr(10) Then
Range("D" & ActiveCell.Row + 1).Value = Mid(Range("D" & ActiveCell.Row + 1).Value, 19, Len(Range("D" & ActiveCell.Row + 1).Value) - 18)
End If
End If
Next
Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Set myList = Range("E4:E" & rNumber)
For Each X In myList
If Left(X, 10) = "Priority:" & Chr(10) Then
X.Select
If Left(Range("E" & ActiveCell.Row + 1).Value, 10) = "Priority:" & Chr(10) Then
Range("E" & ActiveCell.Row + 1).Value = Mid(Range("E" & ActiveCell.Row + 1).Value, 12, Len(Range("E" & ActiveCell.Row + 1).Value) - 11)
Range("D" & ActiveCell.Row + 2 & ":E" & ActiveCell.Row + 2).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("D" & ActiveCell.Row).Value = "Management Response"
Range("D" & ActiveCell.Row).HorizontalAlignment = xlCenter
Range("D" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("D" & ActiveCell.Row).Interior.Color = 14277081
Range("D" & ActiveCell.Row).Font.Bold = True
Range("E" & ActiveCell.Row).Value = "Target Implementation Date"
Range("E" & ActiveCell.Row).HorizontalAlignment = xlCenter
Range("E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
Range("E" & ActiveCell.Row).Interior.Color = 14277081
Range("E" & ActiveCell.Row).Font.Bold = True
Range("D" & ActiveCell.Row + 1 & ":E" & ActiveCell.Row + 1).Select
Selection.Insert Shift:=xlDown
Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Next
Sheets("Annex II").Select
Range("C4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Ineffective"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Effective"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("D4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""High"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Low"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Moderate"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'Starting to generate the report in MsWord
Sheets("Data Table").Select
Set wdApp = New Word.Application
uName = Environ("Username")
fName = "C:\Users\" & uName & "\World Health Organization\IOS Internal Audit - Form Templates\TeamMate Custom Reports\Draft Report Template\IOS Excel Utility\IOS Template.dotx"
With wdApp
.Visible = True
.Documents.Open fName, , ReadOnly
Range("A2").Copy 'audit code
.Selection.Goto wdGoToBookmark, , , "AuditCodeP1"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeP2"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAI"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAIII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditCodeAIV"
.Selection.PasteSpecial , , , , wdPasteText
Range("C6").Copy 'audit title
.Selection.Goto wdGoToBookmark, , , "AuditTitleP1"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleP2"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAI"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAIII"
.Selection.PasteSpecial , , , , wdPasteText
.Selection.Goto wdGoToBookmark, , , "AuditTitleAIV"
.Selection.PasteSpecial , , , , wdPasteText
If Len(Range("H6")) > 0 Then
Range("H6").Copy 'executive summary
.Selection.Goto wdGoToBookmark, , , "ExecutiveSummary"
.Selection.PasteSpecial , , , , wdPasteText
End If
Sheets("Table of Recommendations").Select
Range("A3").Select 'table of recommendations
Range(Selection, Selection.End(xlToRight)).Select 'table of recommendations
Range(Selection, Selection.End(xlDown)).Select 'table of recommendations
Application.CutCopyMode = False
Selection.Copy
Range("H3").Select
ActiveSheet.Paste
Selection.Columns.AutoFit
Application.CutCopyMode = False
'merging and centering the bold lines
Range("H4").Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 5)).Select
Range(Selection, Selection.End(xlDown)).Select
Set StartCell = Range("H4")
Set myList = Range("H4:H" & Range("H" & Rows.Count).End(xlUp).Row)
For Each X In myList
If X.Font.Bold = True Then
X.Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 5)).Merge
End If
Next
Range("H3").Select 'table of recommendations into the word document.
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="(blank)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "TableOfRecommendations"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows(1).Select
.Selection.Rows.HeadingFormat = True
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
Range("H3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Sheets("Data Table").Select
If Len(Range("G6")) > 0 Then
Range("G6").Copy 'introduction
.Selection.Goto wdGoToBookmark, , , "Introduction"
.Selection.PasteSpecial , , , , wdPasteText
End If
If Len(Range("F6")) > 0 Then
Range("F6").Copy 'objective, scope, and approach
.Selection.Goto wdGoToBookmark, , , "ObjectiveScopeApproach"
.Selection.PasteSpecial , , , , wdPasteText
End If
If Len(Range("I6")) > 0 Then
Range("I6").Copy 'audit conclusion
.Selection.Goto wdGoToBookmark, , , "AuditConclusion"
.Selection.PasteSpecial , , , , wdPasteText
End If
If Len(Range("H6")) > 0 Then
Range("I6").Copy 'good practices
.Selection.Goto wdGoToBookmark, , , "GoodPractices"
.Selection.PasteSpecial , , , , wdPasteText
End If
Sheets("Annex II").Select
Range("A3").Select 'annex II
Range(Selection, Selection.End(xlToRight)).Select 'annex II
Range(Selection, Selection.End(xlDown)).Select 'annex II
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "AnnexII"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows(1).Select
.Selection.Rows.HeadingFormat = True
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
Sheets("Annex of Low Risk Recs").Select
Range("A3").Select 'Annex of Low Risk Recs
Range(Selection, Selection.End(xlToRight)).Select 'Annex of Low Risk Recs
Range(Selection, Selection.End(xlDown)).Select 'Annex of Low Risk Recs
Application.CutCopyMode = False
Selection.Copy
Range("D3").Select
ActiveSheet.Paste
Selection.Columns.AutoFit
Application.CutCopyMode = False
'merging and centering the bold lines
Range("D3").Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Select
Range(Selection, Selection.End(xlDown)).Select
Set StartCell = Range("D4")
Set myList = Range("D4:D" & Range("D" & Rows.Count).End(xlUp).Row)
For Each Y In myList
If Y.Font.Bold = True Then
Y.Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Merge
End If
Next
Range("D3").Select 'Annex of Low Risk Recs
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="(blank)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "AnnexIII"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows(1).Select
.Selection.Rows.HeadingFormat = True
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Sheets("Main Body of the Report").Select
Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row
Range("D4:" & "E" & ActiveCell.Row).Select 'main body of the report
Selection.Copy
.Selection.Goto wdGoToBookmark, , , "MainBody"
.Selection.PasteExcelTable False, False, False
.Selection.Tables(1).Rows.Height = 0
.Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
.Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
With .Selection.Find
.Text = "Observations: "
.Replacement.Text = "Observations:^t^t^t^t^t^t^t^t^t"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
Sheets("Main Body of the Report").Select
Columns("D:E").Select
Selection.Clear
'Start from the top of the document
wdApp.Selection.HomeKey wdStory
sFindText = "|H1|"
wdApp.Selection.Find.Execute sFindText
Do Until wdApp.Selection.Find.Found = False
wdApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
wdApp.Selection.Style = ActiveDocument.Styles("Heading 1")
wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wdApp.Selection.ParagraphFormat.Space1
wdApp.Selection.ParagraphFormat.SpaceBefore = 12
wdApp.Selection.MoveRight
wdApp.Selection.Find.Execute
Loop
wdApp.Selection.HomeKey wdStory
sFindText = "|H2|"
wdApp.Selection.Find.Execute sFindText
Do Until wdApp.Selection.Find.Found = False
wdApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
wdApp.Selection.Style = ActiveDocument.Styles("Heading 2")
wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wdApp.Selection.ParagraphFormat.Space1
wdApp.Selection.ParagraphFormat.SpaceAfter = 12
wdApp.Selection.ParagraphFormat.SpaceBefore = 12
wdApp.Selection.MoveRight
wdApp.Selection.Find.Execute
Loop
wdApp.Selection.HomeKey wdStory
wdApp.Selection.Find.ClearFormatting
wdApp.Selection.Find.Replacement.ClearFormatting
With wdApp.Selection.Find
.Text = "|H1|"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute Replace:=wdReplaceAll
With wdApp.Selection.Find
.Text = "|H2|"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute Replace:=wdReplaceAll
End With
For Each sht In Application.Worksheets
sht.Sort.SortFields.Clear
Next sht
Set xlApp = Excel.Application
With xlApp
.Visible = True
Sheets("Data Table").Select
Range("A2").Select
MsgBox "Report generated corectly in Ms Word. You may now close the Excel file.", vbOKOnly, "Good news!"
End With
End Sub