0

いくつかの場所でマージされている列で特定の単語を検索する必要があり、それが存在する場合は、マージされているその行をコピーして別のシートに貼り付ける必要があります。
私が使用する以下のコードは、単語を含む最初のマージされた行のみをコピーして貼り付けると、エラーが発生します。シート全体を調べて、この単語を含むすべての行をコピーする必要があります。

コードにコメントしたので、簡単にフォローできます。

Sub SearchForString()
    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer

    On Error GoTo Err_Execute
    'Start search in row 10
    LSearchRow = 11
    'Start copying data to row 1 in Sheet12 (row counter variable)
    LCopyToRow = 1
    While Len(Range("A" & CStr(LSearchRow)).Value) <> Null
        'If value in column E = "ENGINE AUXILIARY PANEL (EAP 1)", copy entire row to Sheet12
        If Range("E" & CStr(LSearchRow)).Value = "13.8kV SWITCHGEAR METERING CELL #A1 (+06)" Then
            'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy
            'Paste row into Sheet2 in next row
            Sheets("Sheet14").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
            'Move counter to next row
            LCopyToRow = LCopyToRow + 1
            'Go back to Sheet1 to continue searching
            Sheets("Sheet11").Select
        End If
        LSearchRow = LSearchRow + 1
    Wend
Exit Sub

Err_Execute:
4

2 に答える 2

0

あなたのコードを見ると、なぜエラーが発生するのかわかりません。ただし、必ずに置き換える必要があります。そうしない<> Nullと<> 0、ループに入ることがありません（Len常に数値が返されるため、NULLになることはありません）。

ただし、別のアプローチでコードを大幅に最適化できると思います。オートフィルターを使用して検索語をフィルター処理し、表示されているすべての行をコピーするだけです。そうすることで（そして他のいくつかのVBAショートカットを使用して）、基本的に4つの命令になりました。

Sub nextVersion()
    Dim rngAll As Range

    With Worksheets("Sheet11")
        Set rngAll = .Range("A1").Resize( _
            .Cells(Rows.Count, 1).End(xlUp).Row, 5)
        rngAll.AutoFilter Field:=5, Criteria1:= _
            "13.8kV SWITCHGEAR METERING CELL #A1 (+06)"
        If rngAll.SpecialCells(xlCellTypeVisible).Columns.Count > 1 Then
            rngAll.Offset(1).Resize(rngAll.Rows.Count - 1). _
                SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                Worksheets("Sheet14").Range("1:1")
        End If
        rngAll.AutoFilter
    End With
End Sub

更新 データ内のセルをマージした場合、オートフィルターソリューションは機能しません。これでうまくいくはずです：

Sub CopyRows()
    Dim rng As Range
    Dim lngRows As Long
    Dim lngTargetRow As Long
    Dim lngRowsToCopy As Long

    Set rng = Sheet11.Range("E11")
    lngTargetRow = 0
    lngRows = Sheet11.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    Worksheets("Sheet14").UsedRange.Clear

    While rng.Row < lngRows
        lngRowsToCopy = rng.MergeArea.Rows.Count
        If rng.Value = "13.8kV SWITCHGEAR METERING CELL #A1 (+06)" Then
            rng.MergeArea.EntireRow.Copy _
                Worksheets("Sheet14").Range("A1").Resize(lngRowsToCopy).Offset(lngTargetRow).EntireRow
            lngTargetRow = lngTargetRow + lngRowsToCopy
        End If
        Set rng = rng.Offset(1)
    Wend

End Sub
于 2013-02-21T23:14:04.533 に答える
-1 
{
Sub FindTheFeret()
With Worksheets(1).Cells
Set c = .Find("Feret", LookIn:=xlValues)
i = 1
If Not c Is Nothing Then
    firstAddress = c.Address
    Do
        c.EntireRow.Copy
        Worksheets(2).Rows(i).EntireRow.PasteSpecial
        i = i + 1
        Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
}
于 2013-07-30T15:44:16.483 に答える