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

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中将一行从一个工作表复制到另一个工作表。我有两张床单。一个叫做“主人”,一张叫做“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.

我确定我正在做一些非常愚蠢的事情,导致这无法奏效。我可以运行宏本身没有任何错误,但没有任何东西被复制到我正在寻找编译的工作表。

3 个解决方案

#1

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

如果(Len(cell.Value)= 0)则退出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

#2

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 filter does 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 thatmaster is 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/

#3

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)然后退出For

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

我没有使用if来检测范围的结尾,而是使用了以下代码:

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. :-)

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