根據單元格值將行從一個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 

我與您的工作簿測試這和它完美的作品。 :-)