Excel VBA - 转换为单词的边框问题

Question

我正在使用用户表单将数据传输到工作表中，然后将其转换为 Word 文档。我创建了一堆表格来填写用户表单文本框。由于某些 cmets 可能很长，我将这些表设置为换行文本和自动调整行高。虽然有些表格适合字页，但其中一些超出了页面，有些边框在页面下方没有正确的格式。borders。 我删除了单词表中的内容，你可以认为它是全文本的。

我怎样才能使这些边框适合word文档而不溢出到其他页面？

Sub TestingMacAndWin1()
Application.ScreenUpdating = False
Dim appWD As Object
Dim wddoc As Object

On Error Resume Next
Set appWD = GetObject(, "Word.application")
If Err = 429 Then
    Set appWD = CreateObject("Word.application")
    Err.Clear
End If

Set wddoc = appWD.Documents.Add
appWD.Visible = True

With appWD.ActiveDocument.PageSetup
    .Orientation = 1
    .Content.Style = .Styles("No Spacing")
    .TopMargin = appWD.InchesToPoints(0.3)
    .BottomMargin = appWD.InchesToPoints(0.3)
    .LeftMargin = appWD.InchesToPoints(0.3)
    .RightMargin = appWD.InchesToPoints(0.3)
    .InsertBreak Type:=0

End With

Sheets("Sheet1").Range("B4").CurrentRegion.Copy
appWD.Selection.Paste



Sheets("C").Range("C6:F20").Copy
appWD.Selection.Paste

With appWD.Selection
    .Collapse Direction:=0
    .InsertBreak Type:=7
End With





For i = 1 To wddoc.Tables.Count - 1
wddoc.Tables(i).Select
wddoc.Tables(i).AutoFitBehavior wdAutoFitWindow
With wddoc.Tables(i).Range
.bordersall = True
.Font.Name = "Calibri"

End With
Next i



appWD.Activate

Application.ScreenUpdating = True

End Sub

Answer 1

将您的 appWD.Selection.Paste 替换为 appWD.Selection.PasteExcelTable False, True, False。这对我来说很好用：

Sub TestingMacAndWin1()
Application.ScreenUpdating = False
Dim appWD As Object
Dim wddoc As Object

On Error Resume Next
Set appWD = GetObject(, "Word.application")
If Err = 429 Then
    Set appWD = CreateObject("Word.application")
    Err.Clear
End If

Set wddoc = appWD.Documents.Add
appWD.Visible = True

With appWD.ActiveDocument.PageSetup
    .Orientation = 1
    .Content.Style = .Styles("No Spacing")
    .TopMargin = appWD.InchesToPoints(0.3)
    .BottomMargin = appWD.InchesToPoints(0.3)
    .LeftMargin = appWD.InchesToPoints(0.3)
    .RightMargin = appWD.InchesToPoints(0.3)
    .InsertBreak Type:=0

End With



Sheets("Sheet1").Range("a1").CurrentRegion.Copy
appWD.Selection.PasteExcelTable False, True, False


Sheets("Sheet1").Range("b1:F20").Copy
appWD.Selection.PasteExcelTable False, True, False

End Sub

之前：

粘贴更改后：