4

セルに特定の数値/値があることに基づいて、Excel内のあるシートから別のシートに行をコピーできる単純なExcelマクロを探しています。2枚あります。「マスター」と呼ばれるものと「トップ10」と呼ばれるシート。

以下はデータの一例です。

データ表現

使用しようとしているマクロは次のとおりです。

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

これが機能しない原因となっている非常にばかげたことをしていると確信しています。エラーなしでマクロ自体を実行できますが、コンパイルしようとしているシートには何もコピーされません。

4

3 に答える 3

0

データの最初の行の後にコードが停止する理由は、次の行でテストしているセルが空であり(例のスプレッドシートで)、ループを終了するためだと思います(理由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/

于 2013-06-29T18:49:48.403 に答える
0

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
于 2013-06-29T14:28:53.860 に答える
0

@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

これをワークブックでテストしたところ、完全に機能しました。:-)

于 2014-10-10T04:05:02.987 に答える