VBA 用于复制 table 中最高行的脚本

Question

我有一个 table，工作表中有一个名为 'DL data calculation' 的数据。我想将 table (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:$E"), , 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")

你为什么select这一行？您确实想要 select 此处的第一个可见行吗？此行只是 select 活动 selection 的“EntireRow”。

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 列）
存在于活动 sheet 上的列表并将其粘贴到
范围 (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

VBA 用于复制 table 中最高行的脚本

VBA script for copying highest row in table

excel

vba

copy-paste

userform