Итак, это почти тот же самый подход, просто переработанный в форму, которая изолирует каждый шаг вашего процесса, уточняя, чего вы хотите достичь.Наличие вложенного цикла не является проблемой, если вы отслеживаете то, что пытаетесь сделать.То, от чего я хочу уклониться, - это использование GoTo утверждений.Они почти никогда не нужны.
Итак, обо всем по порядку ...
Всегда используйте Option Explicit и объявляйте свои переменные как можно ближе к тому месту, где вы хотите их использовать.Эта привычка облегчает понимание того, что представляет собой каждая переменная и для чего она используется.Если вы объявляете их все в верхней части, вы всегда будете возвращаться туда и обратно, чтобы найти их.
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Поскольку вы всегда будете ссылаться на свой фильтр в одном и том же месте, просто определите переменную, котораяспециально соответствует вашему фильтру.Бонус здесь заключается в том, что если ваш фильтр меняется со строки 7 на строку 8 (например), вам нужно изменить его только в одном месте.
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Используя ту же идею, установите переменную, которая четко определяетрабочие листы, которые нужно пропустить:
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Этот ответ дает отличную функцию, чтобы проверить, существует ли имя вашего рабочего листа в этом массиве.
Вы не включили свою функциюдля LastRow, поэтому я включил его в свой ответ.Тем не менее, сделайте привычку называть свои функции, используя глагол, который описывает, что делает функция.В этом случае FindLastRow.
Чтобы прекратить использование операторов GoTo, просто измените оператор If и продолжите, если он пройдет:
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
Я создал отдельную функциюкоторый сравнивает данную строку с вашим фильтром.Он использует в основном ту же логику, но, изолируя ее как функцию, он делает вашу основную логику более простой для чтения.Кроме того, обратите внимание, что вы можете выйти из цикла For и избежать страшных GoTo:
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
Таким образом, ваш цикл копирования в конечном итоге будет выглядеть так:
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
ВотВесь модуль:
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
'--- now copy the data from this sheet back to the source
' in reverse order, using the source filter line to
' direct which cells to copy
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
End If
End If
Next sh
End Sub
Private Function IsInArray(ByVal stringToBeFound As String, _
ByRef arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
With thisWS
FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
End Function
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function