VBA скрипт для копирования самой высокой строки в таблице

Question

У меня есть таблица с данными на листе под названием «Расчет данных DL». Я хочу скопировать самую высокую строку в таблице (A21: E21) (после фильтрации) в (Y3: AC3). Проблема, с которой я сталкиваюсь сейчас, заключается в том, что когда я объявляю диапазон, пытающийся фильтровать, копируется только строка ячеек A21: E21 вместо самой высокой строки. Кто-нибудь может мне помочь? Я ввел скрипт, который использовал ниже.

Sub CopySelectionVisibleRowsEnd()
Dim ws As Worksheet
Dim mySel As Range
Dim lRow As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long

Set ws = ActiveSheet
Set mySel = Selection.EntireRow
Set myList = ActiveCell.ListObject
myListRows = myList.Range.Rows.Count
myListCols = myList.Range.Columns.Count
lRow = ws.Cells.Find(What:="*", _
    SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, _
    LookIn:=xlValues).Row + 1

mySel.SpecialCells(xlCellTypeVisible).Copy
ws.Cells(lRow, 1).PasteSpecial Paste:=xlPasteAll

lRowNew = ws.Cells.Find(What:="*", _
    SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, _
    LookIn:=xlValues).Row + 1
lRowsAdd = lRowNew - lRow

With myList
.Resize ws.Range(.Range.Resize(myListRows + lRowsAdd, myListCols).Address)
End With

Application.CutCopyMode = False
End Sub

Answer 1

Я внес некоторые изменения для создания примера данных и рабочего кода:

Sub CreateSampleData()
Range("A21") = "F1"
Range("B21") = "F2"
Range("C21") = "F3"
Range("D21") = "F4"
Range("E21") = "F5"
Range("A22:E62") = "=INT(RAND()*1000)"
Range("A22:E62").Copy
Range("A22").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$21:$E$62"), , xlYes).Name = "Table1"
End Sub

Sub CopySelectionVisibleRowsEnd()
Dim ws As Worksheet
Dim mySel As Range
Dim lRow As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long

Set ws = ActiveSheet 'Sheets("Tabelle1")

Почему вы выбираете эту строку? Вы хотите выбрать первую видимую строку здесь? Эта строка просто выбирает «Весь ряд» активного выделения.

Set mySel = Selection.EntireRow

Давайте продолжим с вашим кодом:

Set myList = ActiveCell.ListObject
myListRows = myList.Range.Rows.Count
myListCols = myList.Range.Columns.Count
lRow = ws.Cells.Find(What:="*", _
    SearchOrder:=xlRows, _
    SearchDirection:=xlNext, _
    LookIn:=xlValues).Row + 1

'Here you copy the row of the active cell (if its visible).
'If you select a cell and make it unvisible with the filter
'you select nothing!
'mySel.SpecialCells(xlCellTypeVisible).Copy

'If you select a cell after the filter this can be copied with
'your code - first 5 cells only:
mySel.Range("A1:E1").SpecialCells(xlCellTypeVisible).Copy

' You want to paste to Cell Y3?
'ws.Cells(lRow, 1).PasteSpecial Paste:=xlPasteAll
ws.Range("Y3").PasteSpecial Paste:=xlPasteAll                  

'what is it that you want to achieve here?
lRowNew = ws.Cells.Find(What:="*", _
    SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, _
    LookIn:=xlValues).Row + 1
lRowsAdd = lRowNew - lRow

'I have no idea what you want to achieve here:
'With myList
'.Resize ws.Range(.Range.Resize(myListRows + lRowsAdd, myListCols).Address)
'End With

Application.CutCopyMode = False
End Sub

С приведенными выше изменениями, по крайней мере, код работал.
В какую бы строку курсор не помещался вручную -> эта строка копируется в диапазон «Y3: AC3»

С помощью приведенного ниже кода я копирую первую видимую строку (столбец от A до E)
списка, существующего на активном листе, и вставьте его в
диапазон (Y3: AC3).

Sub CopySelectionVisibleRowsEnd_NEW()
Dim myList As ListObject
Set myList = ActiveSheet.ListObjects(1) 'ActiveSheet.ListObjects("Table1")
Set CopyRange = myList.Range.Offset(1).SpecialCells(xlCellTypeVisible).Range("A1:E1")
CopyRange.Copy
Range("Y3").PasteSpecial Paste:=xlPasteAll
'or PasteValues:
'Range("Y3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub