vba 根据单元格值将行从一个 Excel 工作表复制到另一个

Copying rows from one Excel sheet to another based on cell value

提问by Kristen Poole

I'm looking for a simple excel macro that can copy a row from one sheet to another within excel based upon having a specific number/value in the cell. I have two sheets. One called "master" and a sheet called "top10".

我正在寻找一个简单的 excel 宏，它可以根据单元格中的特定数字/值将一行从一张纸复制到 excel 中的另一张纸。我有两张床单。一个叫做“master”，一个叫做“top10”。

Here is an example of the data.

这是数据的示例。

Here's the macro I'm trying to use:

这是我尝试使用的宏：

Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
    If (Len(cell.Value) = 0) Then Exit For
        For i = 0 To UBound(aTokens)
            If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
                iMatches = (iMatches + 1)
                Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
            End If
        Next
Next
End Sub

I'm sure I'm doing something extremely silly that's causing this not to work. I can run the macro itself without any error, but nothing gets copied to the sheet I'm looking to compile.

我敢肯定我正在做一些非常愚蠢的事情，导致这不起作用。我可以在没有任何错误的情况下运行宏本身，但没有任何内容被复制到我要编译的工作表中。

回答by nixda

If (Len(cell.Value) = 0) Then Exit Foris nonsense. Change it like below:

If (Len(cell.Value) = 0) Then Exit For是胡说八道。像下面这样改变它：

Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
    If Len(cell.Value) <> 0 Then
        For i = 0 To UBound(aTokens)
            If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
                iMatches = (iMatches + 1)
                Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
            End If
        Next
    End If
Next
End Sub

回答by Ioannis

I believe the reason your code stops after the first row of data is because the cell your are testing in the next row is empty (in your example spreadsheet) and therefore you exit the loop (because Len(cell.Value) = 0). I would suggest a different approach: an advanced filterdoes exactly what you need, and is faster. In your example spreadsheet, you will need to insert an empty row 2 and put the formula "=10" in cell A2. Then the code below will do what you need (assuming thatmasteris the ActiveSheet):

我相信您的代码在第一行数据后停止的原因是因为您在下一行中测试的单元格是空的（在您的示例电子表格中），因此您退出循环（因为Len(cell.Value) = 0）。我建议采用不同的方法：高级过滤器完全满足您的需求，而且速度更快。在您的示例电子表格中，您需要插入一个空行 2 并将公式“=10”放入单元格 A2。然后下面的代码将执行您需要的操作（假设master是 ActiveSheet）：

Sub CopyData()
    Dim rngData As Range, lastRow As Long, rngCriteria As Range
    With ActiveSheet
        ' This finds the last used row of column A
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        ' Defines the criteria range - you can amend it with more criteria, 
        ' it will still work
        ' 22 is the number of the last column in your example spreadsheet
        Set rngCriteria = .Range(.Cells(1, 1), .Cells(2, 22))

        ' row 2 has the filter criteria, but we will delete it after copying
        Set rngData = .Range(.Cells(1, 1), .Cells(lastRow, 22))

        ' Make sure the destination sheet is clear
        ' You can replace sheet2 with Sheets("top10"), 
        ' but if you change the sheet name your code will not work any more. 
        ' Using the vba sheet name is usually more stable
        Sheet2.UsedRange.ClearContents

        ' Here we select the rows we need based on the filter 
        ' and copy it to the other sheet
        Call rngData.AdvancedFilter(xlFilterCopy, rngCriteria, Sheet2.Cells(1, 1))

        ' Again, replacing Sheet2 with Sheets("top10").. 
        ' Row 2 holds the filter criteria so must be deleted
        Sheet2.Rows(2).Delete
    End With
End Sub

For a reference to advanced filters, check out this link: http://chandoo.org/wp/2012/11/27/extract-subset-of-data/

有关高级过滤器的参考，请查看此链接：http: //chandoo.org/wp/2012/11/27/extract-subset-of-data/

回答by JME

As @Ioannis mentioned, your problem is the empty cell in master A3 combined with your If (Len(cell.Value) = 0) Then Exit For

正如@Ioannis 提到的，您的问题是主 A3 中的空单元格与您的 If (Len(cell.Value) = 0) Then Exit For

Instead of using an that ifto detect the end of your range I used the following code:

我没有使用 thatif来检测范围的结束，而是使用了以下代码：

LastRow= Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)

The resulting code is this:

结果代码是这样的：

Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
Dim LastRow
Dim MyRange 

LastRow = Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)

For Each cell In MyRange
        For i = 0 To UBound(aTokens)
            If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
                iMatches = (iMatches + 1)
                Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
            End If
        Next
Next
End Sub

I tested this with your workbook and it works perfectly. :-)

我用你的工作簿测试了这个，它工作得很好。:-)