For Each ... Следующая инструкция не работает должным образом

Question

У меня есть несколько рабочих листов с различными финансовыми кавычками в определенных строках, причем до четырех из этих строк содержат галочку (шрифт Marlett буква «а»). Мой код VBA предназначен для идентификации отмеченных строк и переноса этих строк только в другую сводную таблицу.

Проблема в том, что мой код циклически перебирает диапазон и копирует строки, но не всегда отмеченные и часто дублирует их. Трудно кратко резюмировать, и лучше открыть книгу Excel с некоторыми данными (которые я анонимизировал, чтобы не разглашать личные данные).

Мне помогли упростить мой оригинальный код на этом форуме, и это код этого плаката, который я вставил ниже (за что я очень благодарен, кстати!).

Private Sub CopyRows()

Dim cel2 As Range

ScreenUpdating = False

With Sheets("QChecklist1")
    For Each Cell In .Range("E8:E30")
        If Cell.Value = "a" Then
            Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
            Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
            cel2.Value = cel2.Value
            Set cel2 = Nothing
        End If
    Next
End With

With Sheets("QChecklist2")
    For Each Cell In .Range("E8:E30")
        If Cell.Value = "a" Then
            Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
            Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
            cel2.Value = cel2.Value
            Set cel2 = Nothing
        End If
    Next
End With

With Sheets("QChecklist3")
    For Each Cell In .Range("E8:E30")
        If Cell.Value = "a" Then
            Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
            Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
            cel2.Value = cel2.Value
            Set cel2 = Nothing
        End If
    Next
End With

With Sheets("QChecklist4")
    For Each Cell In .Range("E8:E30")
        If Cell.Value = "a" Then
            Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
            Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
            cel2.Value = cel2.Value
            Set cel2 = Nothing
        End If
    Next
End With

Sheets("QAnalysisForm").Activate
cells(1, 1).Select

On Error Resume Next


ScreenUpdating = True

End Sub

Я ожидал, что этот код будет искать в каждом диапазоне на каждом Рабочий лист 'QChecklist' ищет «отмеченные» строки (которые являются шрифтом Marlett а), скопируйте и вставьте его в рабочий лист QAnalysisForm.

Что на самом деле происходит, я загружу изображение, но по существу:

Он находит (в случае QChecklist1) четыре отмеченные галочкой строки, затем повторяет второй и четвертый, затем повторяет все четыре ряда в два раза больше! В общей сложности я получаю 14 строк вместо 4 желаемых! На другой QChecklist рабочие листы (то есть QChecklists 2, 3 и 4, для которых я кодировал) я получаю похожие схемы повторения.

Я также ожидал, что отмеченные строки будут перенесены из всего списка QChecklist рабочие листы в один рабочий лист QAnalysis (сводка лучших цитат), но вместо этого код только поднимает строки из листа, который содержит кнопка макроса Я могу жить с этим, нуждаясь в отдельном запуске на каждом рабочем листе, поскольку в большинстве случаев обычно есть только один или два рабочих листа, но в моем тестовом примере есть четыре отдельных рабочих листа.

Изображение повторяющихся строк Ссылка: https://www.dropbox.com/s/rltdbjcui3q6843/Image%20of%20Repeating%20Rows.png?dl=0

Рабочая книга Excel, содержащая рабочие таблицы для анализа предложений: https://www.dropbox.com/s/3bxxxs54cruyqi2/QuotationAnalysisSystemBeta.xlsm?dl=0

Answer 1

Rows относится к ActiveSheet.Чтобы использовать лист "With", используйте .Rows

. Вы также выполняете немного дополнительной работы для себя, имея один и тот же код четыре раза.Это означает, что вы должны внести одно и то же изменение в нескольких местах, рискуя ошибками.

Есть несколько способов решить эту проблему, но в этом случае простой саб проще всего.

Private Sub CopyRows()
    ScreenUpdating = False

    doWork Sheets("QChecklist1")
    doWork Sheets("QChecklist2")
    doWork Sheets("QChecklist3")
    doWork Sheets("QChecklist4")

    Sheets("QAnalysisForm").Activate
    Cells(1, 1).Select

    On Error Resume Next

    ScreenUpdating = True
End Sub

Private Sub doWork(sht As Worksheet)
    Dim cel2 As Range
    With sht
        For Each Cell In .Range("E8:E30")
            If Cell.Value = "a" Then
                Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
                .Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
                cel2.Value = cel2.Value
                Set cel2 = Nothing
            End If
        Next
    End With
End Sub