Hi Fiona,
If I follow this time it seems only necessary to check for PatRev names in
column-C cells, then get the whole row - right?
Also, if I understand, all these cells will include a SubTotal formula, that
will help a lot to restrict the search of named cells (see code).
In a new wb, first run SampleDataAndNames and see if the sample data & names
is something like what you are working with. Will be looking to copy data in
the yellow rows, but not the green rows which also have Subtotals and named
cells.
In GetFilteredData look at the SpecialCells line. This is like manually
select col-c, F5 > Special > Formulas tick only numbers & errors. Will that
work for you too, otherwise ignore and use the alternative commented rng.
Try both methods with bUseFilterMethod = True & Fasle
If True, fills column-P with True's in rows to filter, ie named cells in
col-c that start with PatRev. I've omitted the code to apply the filter and
copy to a new sheet but that will be very similar to the macro you posted
previously.
Probably, but depending on your data, the non-filter method will work just
as well if not better.
Sub SampleDataAndNames()
Dim b As Boolean
Dim i&, r As Range
Dim ws As Worksheet
Dim arr(1 To 23000, 1 To 1)
Set ws = Worksheets("Sheet4")
For i = 1 To UBound(arr)
arr(i, 1) = i
Next
For Each r In ws.Range("A1
23000").Columns
r.Value = arr
Next
With ws.Range("C1
23000")
For i = 100 To 23000 Step 100
.Rows(i).FormulaR1C1 = "=SUBTOTAL(9,R[-99]C:R[-1]C)"
b = Not b
If b Then
.Cells(i, 1).Name = "PatRev_C" & Right("0000" & i, 5)
.Rows(i).Interior.Color = vbYellow
Else
.Rows(i).Cells(1, 1).Name = "PatData_C" & Right("0000" & i,
5)
.Rows(i).Interior.Color = vbGreen
End If
Next
End With
End Sub
Sub GetFilteredData()
Dim b As Boolean
Dim i As Long, j As Long, cnt As Long
Dim lastRow As Long
Dim rng As Range, cel As Range
Dim wsFrom As Worksheet, wsTo As Worksheet
Dim bUseFilterMethod As Boolean ' for testing
Set wsFrom = ActiveWorkbook.Worksheets("Sheet4")
lastRow = wsFrom.Range("C" & wsFrom.Rows.Count).End(xlUp).Row
Set wsTo = ActiveWorkbook.Worksheets("Sheet2")
On Error Resume Next
'' Can we restrict search to formula cells like =SubTotal(
'' ( the 17 refers to numbers & errors in goto special Ctrl-F5)
Set rng = wsFrom.Columns("C:C").SpecialCells(xlCellTypeFormulas, 17)
If rng Is Nothing Then
MsgBox "no formulas in Col-C !"
Exit Sub
End If
''if can't use Specialcells will need to check all cells for names in
col-c
''23k cells will be slow, avoid if possible
'Set rng = wsFrom.Range("C1:C" & lastRow)
ReDim arridx(1 To rng.Count) As Long
i = 0
'' unnamed cells will error below, so do this with on
'' error resume next (already set above)
For Each cel In rng
b = LCase(Left(cel.Name.Name, 6)) = "patrev"
If b Then
i = i + 1
arridx(i) = cel.Row
cnt = cnt + 1
b = False
End If
Next
On Error GoTo 0
If cnt = 0 Then
MsgBox "no matching names found"
Exit Sub
ElseIf cnt < UBound(arridx) Then
ReDim Preserve arridx(1 To cnt)
End If
'bUseFilterMethod = True
If bUseFilterMethod Then
ReDim varr(1 To lastRow, 1 To 1)
For i = 1 To cnt
varr(arridx(i), 1) = True
Next
wsFrom.Range("P1
" & lastRow).Value = varr
' set the filter on col-P for True,
' copy filtered range to new sheet
' remove the filter and clear contents in col-p
Else
ReDim arrCopy(1 To cnt, 1 To 15) ' 1 to 15 refers to cols a to o
With wsFrom.Range("a1
" & lastRow)
For i = 1 To cnt
For j = 1 To 15
arrCopy(i, j) = .Cells(arridx(i), j)
Next
Next
End With
wsTo.Range("a1
" & cnt).Value = arrCopy
End If
End Sub
Regards,
Peter T
