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

Question

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

这是数据的示例。

这是我尝试使用的宏：

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

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

Answer 1

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

Answer 2

我相信您的代码在第一行数据后停止的原因是因为您在下一行测试的单元格是空的（在您的示例电子表格中），因此您退出循环（因为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

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

Answer 3

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

我没有使用if来检测范围的末尾，而是使用了以下代码：

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

结果代码是这样的：

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

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