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

Question

我正在寻找一个简单的excel宏，它可以基于单元格中具有特定的数字/值将一行从一个工作表复制到另一个工作表内。我有两张床单。一个叫做“主人”，一个叫做“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 

我与您的工作簿测试这和它完美的作品。 :-)