停止将新的行格式更改为Times New Roman

Question

我有两张纸各一张的表。有时需要将工作表1中表格的某些信息移至工作表2中（让它们分别称为“ ApplicationsTable”和“ FinishedTable”）

我为此创建了按钮。首先，您必须选择需要复制的条目行，然后单击按钮，它会在FinishedTable的底部创建新行，并使用AplicationsTable中的信息进行填充。一切工作正常，但出于某种原因，所创建的新行的格式为Times New Roman 11 pt。尽管ApplicationsTable和FinishedTable的其余部分均格式化为Arial 10 pt。

我已经尝试从FinishedTable的上面一行复制和粘贴格式，但是由于某种原因我无法使其工作。您能否给我一些建议，我应该采取什么方法使新行保留原始表格式？我的代码：

Sub Move_info()

Dim shNr As Worksheet
Dim fList As ListObject
Dim nEntry As ListRow
Dim lastRow As Long
Dim xForm As Long
Dim pForm As Long

Set sh1 = Worksheets("Register")
Set shNr = Worksheets("Finished applications")
Set fList = shNr.ListObjects("FinishedTable")
With fList.Range
    lastRow = .Rows(.Rows.Count).Row
End With

'stops macro if selected one than more row
If Selection.Rows.Count > 1 Then
    Exit Sub
End If

'if selected entry doesen't match criteria, stops from copying info
If Range("D" & (ActiveCell.Row)).Value = "Finished" Then
'line for adding new line at the bottom of the FinishedTable
    Set nEntry = fList.ListRows.Add
'Lines for moving info from ApplicationsTable to new row in FinishedTable

    With nEntry
        .Range(1) = shNr.Cells(lastRow, "A").Offset(-1, 0).Value + 1
        .Range(2) = "=Register!T" & ActiveCell.Row
        .Range(4) = sh1.Range("C" & ActiveCell.Row).Value
        .Range(6) = sh1.Range("I" & ActiveCell.Row).Value
        .Range(7) = sh1.Range("H" & ActiveCell.Row).Value
        .Range(10) = sh1.Range("P" & ActiveCell.Row).Value
        .Range(11) = sh1.Range("Q" & ActiveCell.Row).Value
        End With
    'Up to this part code works as intended, line created, info is moved

    'with code below I tried to copy format from one row above last and paste it to last row 
    'I do not get any error, but format remains unchanged

    xForm = shNr.Cells(lastRow, "A").Offset(-1, 0).Row
    Rows(xForm).Copy
    pForm = shNr.Cells(lastRow, "A").Row
    Rows(pForm).EntireRow.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False

    'selects first cell which where user have to write info by hand, works as intended
    Application.GoTo shNr.Cells(lastRow, "C").Offset(1, 0)
End If

End Sub

Answer 1

如果您知道此表的起始位置（假设您的第一个数据行是A2），则可以执行以下操作：

Range("A2").CurrentRegion.Font.Name="Arial"
Range("A2").CurrentRegion.Font.Size=10.

这样，您便可以将所需的格式应用于所有表格。

为什么要在Times New Roman中使用它，可能是因为它是Excel的默认格式。要检查出来，请检查Excel中的选项。我的版本是2007，是西班牙文，但我会做一个广告截图。也许可以帮到您。

首先，单击“ Office / File”按钮，然后单击“ Excel Options”按钮：

此外，找到诸如最常用或最常用之类的部分，在那里您应该可以选择默认格式。

希望这会有所帮助

Answer 2

使用 Foxfire And Burns And Burns 建议，我通过在代码末尾添加Range("A2").CurrentRegion.Font.Name="Arial"和Range("A2").CurrentRegion.Font.Size=10来克服了问题。我仍然不知道为什么我要使用Times New Roman字体，但这也许会帮助遇到类似问题的人。最终代码：

Sub Move_info()

Dim shNr As Worksheet
Dim fList As ListObject
Dim nEntry As ListRow
Dim lastRow As Long

Set sh1 = Worksheets("Register")
Set shNr = Worksheets("Finished applications")
Set fList = shNr.ListObjects("FinishedTable")
With fList.Range
    lastRow = .Rows(.Rows.Count).Row
End With

If Selection.Rows.Count > 1 Then
    Exit Sub
End If

If Range("D" & (ActiveCell.Row)).Value = "Finished" Then
    Set nEntry = fList.ListRows.Add

    With nEntry
        .Range(1) = shNr.Cells(lastRow, "A").Offset(-1, 0).Value + 1
        .Range(2) = "=Register!T" & ActiveCell.Row
        .Range(4) = Range("C" & ActiveCell.Row).Value
        .Range(6) = Range("I" & ActiveCell.Row).Value
        .Range(7) = Range("H" & ActiveCell.Row).Value
        .Range(10) = Range("P" & ActiveCell.Row).Value
        .Range(11) = Range("Q" & ActiveCell.Row).Value
        End With

   Range("A2").CurrentRegion.Font.Name="Arial"
   Range("A2").CurrentRegion.Font.Size=10

    Application.GoTo shNr.Cells(lastRow, "C").Offset(1, 0)
End If

End Sub