VBA для форматирования останавливается в определенном диапазоне

Question

Ну, я думаю, что это глупый вопрос, но я не могу понять их сам.

У меня есть WB, в котором есть различные макросы. Один для копирования шаблона (создание нового WS каждый раз, когда это необходимо), который заполняет пользователь. После этого один макрос для копирования результатов в WS «Summary», затем другой, который применяет формулу, после этого один, который применяет оценку (хорошо, плохо, хорошо) и последний, который копирует формат ячеек scpecifics, чтобы дать правильное форматирование для печати. ​​

Последний действует странно. Я создал более 40 WS (копирование шаблона), но форматирование останавливается на 25-й строке. Я не знаю почему.

Я использовал формулу для копирования до последней строки, но ничто не может заставить эту вещь работать.

Ниже следует результат и код. Я подумал, что проблема может заключаться в том, что я сжал все команды в одной подпрограмме, поэтому я разбил ее на различные и создал кнопку «триггер» для активации всех этих команд.

Если мое объяснение не достаточно, просто попросите дополнительную информацию.

Заранее спасибо за помощь!

Ошибка при форматировании

---

Код, который я использовал.

==============

Sub FormatarCab()

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ActiveSheet

'Using Find Function (Provided by Bob Ulmas)
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

'Para o cabeçalho
Worksheets("Descritivo").Range("B50").Copy
Worksheets("Avaliação Todos").Range("A1:E1").PasteSpecial xlPasteFormats

Application.CutCopyMode = False
End Sub

'-------------------------------------

Sub FormatarNome()

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ActiveSheet

'Using Find Function (Provided by Bob Ulmas)
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

'Para os Nomes das Abas
Worksheets("Descritivo").Range("B52").Copy
Worksheets("Avaliação Todos").Range("A2:A" & LastRow).PasteSpecial xlPasteFormats


Application.CutCopyMode = False
End Sub

'-------------------------------------

Sub FormatarConceito()

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ActiveSheet

'Using Find Function (Provided by Bob Ulmas)
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

'Para o Conceito
Worksheets("Descritivo").Range("B54").Copy
Worksheets("Avaliação Todos").Range("E2:E" & LastRow).PasteSpecial xlPasteFormats


Application.CutCopyMode = False
End Sub

'-------------------------------------

Sub FormatarValores()

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ActiveSheet

'Using Find Function (Provided by Bob Ulmas)
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

'Para os valoreso
Worksheets("Descritivo").Range("B56").Copy
Worksheets("Avaliação Todos").Range("B2:D" & LastRow).PasteSpecial xlPasteFormats


Application.CutCopyMode = False
End Sub

==============

Структура для функции LastRow

==============

Option Explicit

'Common Functions required for all routines:

Function LastRow(Sh As Worksheet)
    On Error Resume Next
    LastRow = Sh.Cells.Find(What:="*", _
                            After:=Sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            searchdirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(Sh As Worksheet)
    On Error Resume Next
    LastCol = Sh.Cells.Find(What:="*", _
                            After:=Sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            searchdirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

==============

Answer 1

Игнорируя функцию LastRow, которую вы добавили в конец кода, но на самом деле не используете, вы устанавливаете переменную с именем LastRow со значением самой низкой ячейки в sht - Set до ActiveSheet.

Затем вы вставляете из E2 в E & LastRow - но не обязательно из ActiveSheet - фактически вы делаете это на Worksheets("Avaliação Todos")

Вы хотите, чтобы LastRow основывался на нижнем ряду листа, на который вы собираетесь наклеивать, - это должно выглядеть так:

Sub FormatarCab()

    Dim LastRow As Long

    With Worksheets("Avaliação Todos")

        'Using Find Function (Provided by Bob Ulmas)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

        'Para o cabeçalho
        Worksheets("Descritivo").Range("B50").Copy
        .Range("A1:E1").PasteSpecial xlPasteFormats

    End With

    Application.CutCopyMode = False
End Sub

'-------------------------------------

Sub FormatarNome()

    Dim LastRow As Long

    With Worksheets("Avaliação Todos")

        'Using Find Function (Provided by Bob Ulmas)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

        'Para os Nomes das Abas
        Worksheets("Descritivo").Range("B52").Copy
        .Range("A2:A" & LastRow).PasteSpecial xlPasteFormats

    End With

    Application.CutCopyMode = False
End Sub

'-------------------------------------

Sub FormatarConceito()

    Dim LastRow As Long

    With Worksheets("Avaliação Todos")

        'Using Find Function (Provided by Bob Ulmas)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

        'Para o Conceito
        Worksheets("Descritivo").Range("B54").Copy
        .Range("E2:E" & LastRow).PasteSpecial xlPasteFormats

    End With

    Application.CutCopyMode = False
End Sub

'-------------------------------------

Sub FormatarValores()


    Dim LastRow As Long

    With Worksheets("Avaliação Todos")

        'Using Find Function (Provided by Bob Ulmas)
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

        'Para os valoreso
        Worksheets("Descritivo").Range("B56").Copy
        .Range("B2:D" & LastRow).PasteSpecial xlPasteFormats

    End With

    Application.CutCopyMode = False
End Sub

Answer 2

Если вы ищете последнюю строку или столбец, вы можете использовать ниже:

Dim lc As Long
Dim lr As Long

'Change the 1 to whatever row you would want to be able to check for the last true column.
lc = Cells(1, Columns.Count).End(xlToLeft).Column 'determines total number of columns

'Change the "A" to whatever row would show the last row and be consistent for all your worksheets
lr = Range("A" & Rows.Count).End(xlUp).Row 'determines total number of rows including header

Приведенное выше предполагает, что у вас есть согласованные данные