Excel VBA：从前5行/单元格过滤并复制 [英] Excel VBA: Filter and copy from top 5 rows/cells

问题描述

我有一个数据表按照列F中的降序进行排序。然后，我需要复制前5行，但只需复制列A，B，D和F中的数据（而不是标题）。查看图片

  Sub top5（）
 
表格（Sheet1）。选择
 
如果（ActiveSheet.AutoFilterMode和ActiveSheet.FilterMode）或ActiveSheet.FilterMode然后
 ActiveSheet.ShowAllData 
如果
 
 
 ActiveSheet.Range（ $ A $ 4：$ T $ 321）。AutoFilter Field：= 3，Criteria1：=Dave
 ActiveWorkbook.Worksheets（Sheet1）。AutoFilter.Sort.SortFields。 _ 
清除
 ActiveWorkbook.Worksheets（Sheet1）。AutoFilter.Sort.SortFields.Add _ 
 Key：= Range（F4：F321），SortOn：= xlSortOnValues，Order： = xlDescending，_ 
 DataOption：= xlSortTextAsNumbers 
使用ActiveWorkbook.Worksheets（Sheet1）。AutoFilter.Sort 
 .Header = xlYes 
 .MatchCase = False 
。 Orientation = xlTopToBottom 
 .SortMethod = xlPinYin 
。应用
结束
 
'这个复制粘贴部分做了它应该的，但只针对具体的
'单元格。它不通用，我将不得不重复这个操作
'为不同的人
表（Sheet1）选择
范围（A3：B15）选择$ b $选择
范围（A3）。选择
 ActiveSheet.Paste 
 
表格（选择
范围（D3：D15）。选择
 Application.CutCopyMode = False 
 Selection.Copy 
 
表格（Sheet2）。选择
范围（C3）。选择
 ActiveSheet.Paste 
 
表格（Sheet1）。选择
范围（F3：F15）选择
 Application.CutCopyMode = False 
 Selection.Copy 
 
表格（Sheet2）。选择
范围（D3）。选择
 ActiveSheet。粘贴
 Application.CutCopyMode = False 
 
 End Sub 
  

I想到试图使用可见单元格功能调整下面这段代码，但是我被卡住了，我找不到任何适合的网络。

 '这将选择所有行（加1，可能是由于偏移量），我只想从顶部5的部分。
表格（Sheet1）。选择
 ActiveSheet.Range（$ A $ 4：$ B $ 321）。Offset（1，0）.SpecialCells xlCellTypeVisible）。选择
 Selection.Copy 
表格（Sheet2）。选择
范围（A3）。选择
 ActiveSheet.Paste 
 
表格（Sheet1）。选择
 ActiveSheet.Range（$ D $ 4：$ D $ 321）。Offset（1，0）.SpecialCells（xlCellTypeVisible）.Select 
 Selection.Copy 
 sheet（Sheet2）。选择
范围（C3）。选择
 ActiveSheet.Paste 
  

我希望我的例子是有道理的，我非常感谢你的帮助！

注意：标题名称在两个表中是相同的，以显示数据是相同的。标题不应该被复制。另外，第二个表中还有一个额外的列/空格。一个解决方案应该包括这个。

解决方案

首先有几个帮助点：

• 您应该参考代码名称以避免重命名问题。


• 如果要使用VBA，那么我的建议是避免像瘟疫这样的合并单元格。它们对代码造成破坏。如果可能，使用格式单元格 - 对齐 - 水平 - 中心选择


• 我还建议避免循环，尽可能地利用内置的功能，而不是作为一个良好的练习练习。

这是我的解决方案把事情简单化。如果你需要进一步的帮助，让我现在。

  Sub HTH（）
 
 Dim rCopy As Range 
 
 With Sheet1 .AutoFilter.Range 
'//设置为工作表空白处和未使用的位置
设置rCopy = Sheet1.Range（A& Rows.Count  - （.Rows.Count））
.SpecialCells（xlCellTypeVisible）.Copy rCopy 
结束
 
使用rCopy.Offset（1）.Resize（5）'//偏移以避免头
 .Resize（ ，2）.Copy Sheet2.Range（A5）
 .Offset（，3）.Resize（，1）.Copy Sheet2.Range（D5）
 .Offset（，5）。调整大小（，1）.Copy Sheet2.Range（F5）
 .CurrentRegion.Delete xlUp'//删除tempory区域
结束
 
设置rCopy = Nothing 
 
 End Sub 
  

I have a data table which is sorted on descending order in column F. I then need to copy the top 5 rows, but only data from Column A, B, D, and F (not the headers). See pictures.

Sub top5()

Sheets("Sheet1").Select

If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If


ActiveSheet.Range("$A$4:$T$321").AutoFilter Field:=3, Criteria1:="Dave"
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
    Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
    Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
    DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

' This copy-paste part does what its supposed to, but only for the specific 
' cells.  Its not generalised and I will have to repeat this operation
' several times for different people
Sheets("Sheet1").Select
Range("A3:B15").Select
Selection.Copy

Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste

Sheets("Sheet1").Select
Range("D3:D15").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste

Sheets("Sheet1").Select
Range("F3:F15").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Sheet2").Select
Range("D3").Select
ActiveSheet.Paste
Application.CutCopyMode = False

End Sub

I thought about trying to adapt this snippet of code below using visible cells function, but I'm stuck and I can't find anything on the net which fits.

' This selects all rows (plus 1, probably due to offset), I only want parts of from the top 5.
Sheets("Sheet1").Select
ActiveSheet.Range("$A$4:$B$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste

Sheets("Sheet1").Select
ActiveSheet.Range("$D$4:$D$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste

I hope my example makes sense and I really appreciate your help!

Note: The heading names are only the same in the two tables to show that the data is the same. The headers are NOT supposed to be copied. In addition, there is an extra column/white space in the second table. A solution should include this.

解决方案

Firstly a few helpful points:

• You should refer to worksheets by there Code Name to avoid renaming issues.
• If you want to work with VBA then my advice is to avoid merged cells like the plague. They cause havoc with code. If possible use format cells - alignment - horizontal - centre accross selection
• I also advise avoiding loops wherever possible and take advantage of excels built in functions instead as a good practice exercise.

Here is my solution. Keep it simple. If you need further help let me now.

Sub HTH()

    Dim rCopy As Range

    With Sheet1.AutoFilter.Range
        '// Set to somewhere blank and unused on your worksheet
        Set rCopy = Sheet1.Range("A" & Rows.Count - (.Rows.Count))
        .SpecialCells(xlCellTypeVisible).Copy rCopy
    End With

    With rCopy.Offset(1).Resize(5) '// Offset to avoid the header
        .Resize(, 2).Copy Sheet2.Range("A5")
        .Offset(, 3).Resize(, 1).Copy Sheet2.Range("D5")
        .Offset(, 5).Resize(, 1).Copy Sheet2.Range("F5")
        .CurrentRegion.Delete xlUp '// Delete the tempory area
    End With

    Set rCopy = Nothing

End Sub

这篇关于Excel VBA：从前5行/单元格过滤并复制的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！