Question

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

以下是数据示例。

data representation

这是我正在尝试使用的宏：

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

我用你的工作簿对它进行了测试，效果很好。： - ）

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

3 个答案: