Copying filtered lists efficiently.

[Pquigrafamos]

Hello,

I am currently working on a project where filtered lists with more than 73000 rows are copied into another sheet, this way isolating the relevant rows.
From the original 73000, about 61000 rows are transported to the new tab.
My code works, but it takes way too much time to finish this operation:

Dim Cop1 As Range 'Will be the range to be copied from the filtered tab, from A1 until M(last row).
Dim ws1 As Worksheet 'Will be the tab where the filtered data is isolated.

Set Cop1 = Range(Cells(1, 1), Cells(nRow, 13))
Set ws1 = Sheets.Add(After:=Sheets(InshM))
ws1.Name = "Output_1"

Cop1.Copy ws1.Cells(1, 1)

Can someone advise me on a better way to do this action?

 

[offthelip]

You could try this code where you avoid doing the filtering on the worksheet entirely but do the filtering in VBa, this might well be faster, This code just check whether column A is "a" but change it to whatever condition your filtering for. It is all doen with variant arrays so should be very fast

Sub test()
Dim outarr() As Variant

lastrow = Cells(Rows.Count, "A").End(xlUp).Row

inarr = Range(Cells(1, 1), Cells(lastrow, 13))
ReDim outarr(1 To lastrow, 1 To 13)
indi = 1
For i = 1 To lastrow
   If inarr(i, 1) = "a" Then   ' this is instead of the filter on the worksheet
    For j = 1 To 13
      outarr(indi, j) = inarr(i, 1)
    Next j
    indi = indi + 1
   End If
 Next i
Worksheets.Add
Range(Cells(1, 1), Cells(indi - 1, 13)) = outarr

End Sub

 

[Pquigrafamos]

@offthelip , Many thanks, this would be a very good idea!
I have tried to adapt it to the filtering conditions, but I am not being able to do so.
The conditions are the following:

Criteria1:
StatOP = Array("Developing", "Approved", "Active", "Changed", "np")

Criteria2:
CtrOP = Array("GR", "SK", "CZ", "HU", "CH", "DE", "AT", "IS", "MT", "PL", "EE", "LV", "LT", "GB", "PT", "ES", "NL", "BE", "FR", "IT", "RS", "ME", "BA", "HR", "SI", "RO", _
"BG", "SE", "NO", "DK", "BH", "SA", "AE", "RU", "KW", "QA", "OM", "IE", "FI", "AL", "MK", "CY", "AZ", "MD", "GE", "UA", "LB", "TR", "SN", "GA", "CI", "DZ", "MU", "BY", _
"JP", "DO", "EG", "JO", "AM", "TJ", "UZ", "TM", "KG", "MN", "MG", "EU", "MY", "BN", "SG", "MA", "KZ", "XK", "LU", "IQ", "GI", "LY", "PS", "IR", "SD", "TN", "YE")

Set StatTarR = Insh.Rows(1).Find("Status", , xlValues, xlWhole)
Set CtrTarR = Insh.Rows(1).Find("Countries", , xlValues, xlWhole)

Cells.AutoFilter Field:=StatTar, Criteria1:=Array(StatOP), Operator:=xlFilterValues
Cells.AutoFilter Field:=CtrTar, Criteria1:=Array(CtrOP), Operator:=xlFilterValues

Do you think it is possible to use your idea together with this many criteria taken into consideration?

Best regards!

 

[offthelip]

try this ( untested)

Sub test()
'Criteria1:
Statop = Array("Developing", "Approved", "Active", "Changed", "np")

'Criteria2:
ctrop = Array("GR", "SK", "CZ", "HU", "CH", "DE", "AT", "IS", "MT", "PL", "EE", "LV", "LT", "GB", "PT", "ES", "NL", "BE", "FR", "IT", "RS", "ME", "BA", "HR", "SI", "RO", _
"BG", "SE", "NO", "DK", "BH", "SA", "AE", "RU", "KW", "QA", "OM", "IE", "FI", "AL", "MK", "CY", "AZ", "MD", "GE", "UA", "LB", "TR", "SN", "GA", "CI", "DZ", "MU", "BY", _
"JP", "DO", "EG", "JO", "AM", "TJ", "UZ", "TM", "KG", "MN", "MG", "EU", "MY", "BN", "SG", "MA", "KZ", "XK", "LU", "IQ", "GI", "LY", "PS", "IR", "SD", "TN", "YE")

Set statTarR = Insh.Rows(1).Find("Status", , xlValues, xlWhole)
Crit1col = statTarR.Column
Set CtrTarR = Insh.Rows(1).Find("Countries", , xlValues, xlWhole)
Crit2col = CtrTarR.Column

Dim outarr() As Variant
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 13))
ReDim outarr(1 To lastrow, 1 To 13)
indi = 1
For i = 1 To lastrow
' check criteria 1
   crit1 = False
   For k = 0 To UBound(Statop)
    If inarr(i, Crit1col) = Statop(k) Then
    crit1 = True
    Exit For
    End If
   Next k
' check criteria 2
   crit2 = False
   For k = 0 To UBound(ctrop)
    If inarr(i, Ctrit2col) = ctrop(k) Then
    crit2 = True
    Exit For
    End If
   Next k
   
   If crit1 And crit2 Then   ' this is instead of the filter on the worksheet
    For j = 1 To 13
      outarr(indi, j) = inarr(i, 1)
    Next j
    indi = indi + 1
   End If
 Next i
Worksheets.Add
Range(Cells(1, 1), Cells(indi - 1, 13)) = outarr

End Sub

 

[Pquigrafamos]

@offthelip thank you so much for this, it works brilliantly on office 2016!
Unfortunately, in Office 365 it does not.
Firstly, I had to declare the data types in the following manner:

Dim Insh As Worksheet
Dim InshM As String
Dim i As Long, StatOP As Variant
Dim b As Long, CtrOP As Variant
Dim StatTarR As Range
Dim StatTar As Integer
Dim CtrTarR As Range
Dim CtrTar As Integer
Dim LsetTar As Integer
Dim LsetTarR As Range
Dim nRow As Long
Dim Crit1col As Integer
Dim Crit2col As Integer
Dim lastrow As Long
Dim indi As Long
Dim inarr As Variant
Dim crit1 As Boolean
Dim k As Variant
Dim crit2 As Boolean
Dim j As Integer

After the code still gets stuck in the last piece of code with the error 1004:
Range(Cells(1, 1), Cells(indi - 1, 13)) = outarr

I have tried many ways but nothing seems to work here.
Is there something obvious I am not catching?

Best regards!

 

[Marc L]

Hello,​

​

as a reminder the advanced filter Excel feature is often fast enough so once it works manually it is easy to use it under VBA …​

 

[Pquigrafamos]

@offthelip , meanwhile I have found a way to make it work. Can't thank you enough!! :D