Хватит менять новый формат строки на Times New Roman

Question

У меня есть Excel с двумя листами с одним столом в каждом.Время от времени некоторую информацию из таблицы в sheet1 необходимо перемещать в таблицу sheet2 (давайте назовем их 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 года и на испанском, но я покажу скриншот того, как я это делаю.Может быть, это поможет вам.

Сначала нажмите кнопку «Офис / Файл», а затем нажмите кнопку «Параметры Excel»:

И после этого найдите раздел, называемый чем-то вроде Наиболее часто или Наиболее часто используемые , и там у вас должна быть опция для формата по умолчанию.

Надеюсь, это поможет

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