Reducing ActiveSheet Paste size. Large data showing insufficient memory - excel

Question

Would like seek help on simplifying down some codes. it worked on some smaller set of data but unable to work on this larger set of around 750rows of data. The aim is to simplify down the data set by the criteria of Banker, and saved each filtered results based on Banker on a new tab, and then save as a separate workbook.
Sub seperate_by_banker()
Dim i, n As Integer
Dim banker As String
i = 2
n = Sheets("Banker").Range("A1").End(xlDown).Row
Do Until i = n
banker = Sheets("Banker").Range("A" & i)
Sheets("ASIA CHINA (PC)").Select
ActiveSheet.Range("$A$1:$Y$1000").AutoFilter Field:=7, Criteria1:= _
banker
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = banker
i = i + 1
Loop
Call SplitWorkbook
End Sub
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
MkDir FolderName
For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "\" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

Answer 1

Please, try the next code. It uses array and copy the filtered range after transforming it in an array, so it should be very fast. No need of the second sub, no need of selections, which only consume Excel resources:
Sub seperate_by_banker()
Dim shB As Worksheet, shAC As Worksheet, wbNew As Workbook, lastR As Long, lastRAC As Long
Dim banker As String, rng As Range, rngF As Range, arrB, arr, i As Long, FolderName As String
Set shB = ThisWorkbook.Sheets("Banker")
lastR = shB.Range("A" & shB.rows.count).End(xlUp).row 'last row
arrB = shB.Range("A2:A" & lastR).Value2
Set shAC = ThisWorkbook.Sheets("ASIA CHINA (PC)")
lastRAC = shAC.Range("A" & shAC.rows.count).End(xlUp).row 'last row
FolderName = ThisWorkbook.path & "\" & ThisWorkbook.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
If Dir(FolderName, vbDirectory) = "" Then MkDir FolderName 'create the folder if it does not exist
For i = 1 To UBound(arrB)
banker = arrB(i, 1)
shAC.AutoFilterMode = False 'eliminate the previous filter, if any
Set rng = shAC.Range("A1:Y" & lastRAC) 'set the range to be processed
rng.AutoFilter field:=6, Criteria1:=banker
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set a range to keep the filtered cells in the range
arr = arrayFromDiscRange(rngF, False) 'header inclusive
'create the necessary new workbook:
Set wbNew = Workbooks.Add
With wbNew.Sheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2))
.value = arr
.EntireColumn.AutoFit
End With
wbNew.saveas FolderName & "\" & banker & ".xlsx"
wbNew.Close False
Next i
End Sub
And the necessary function. It transforms the filtered (discontinuous) range in an array and paste it as fast as possible:
Private Function arrayFromDiscRange(rngF As Range, Optional NoHeader As Boolean = False) As Variant
Dim arr, i As Long, j As Long, k As Long, A As Range, R As Range, iRows As Long
'count range rows
For Each A In rngF.Areas
iRows = iRows + A.rows.count
Next A
'Redim the array to keep the range
ReDim arr(1 To iRows - IIf(NoHeader, 1, 0), 1 To rngF.Columns.count): k = 1
For Each A In rngF.Areas 'iterate between the range areas:
For Each R In A.rows 'iterate between the area rows:
If NoHeader And k = 1 Then GoTo Later 'skip the first row, if no header wanted
For j = 1 To R.Columns.count 'iterate between the area row columns:
arr(k, j) = R.cells(1, j).value 'place each row cells value in the array row
Next j
k = k + 1 'increment the array row to receive values
Later:
Next
Next A
arrayFromDiscRange = arr 'returning the created array
End Function

Answer 2

You could create the new workbooks directly from the filtered sheet.
Option Explicit
Sub separate_by_banker()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsData As Worksheet
Dim rng As Range, arBanker As Variant
Dim n As Long, iLastRow As Long
Dim foldername As String, sName As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Banker")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
arBanker = ws.Range("A2:A" & iLastRow).Value2
Set wsData = wb.Sheets("ASIA CHINA (PC)")
iLastRow = wsData.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsData.Range("A1:Y" & iLastRow)
' make folder for workbooks
foldername = wb.Path & "\" & wb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
MkDir foldername
Application.ScreenUpdating = False
For n = 1 To UBound(arBanker)
sName = arBanker(n, 1)
Set wbNew = Workbooks.Add(xlWBATWorksheet) ' 1 sheet
wbNew.Sheets(1).Name = sName
rng.AutoFilter Field:=7, Criteria1:=sName
rng.Copy
wbNew.Sheets(1).Paste
wbNew.Sheets(1).Columns("A:Y").AutoFit
wbNew.SaveAs foldername & "\" & sName & ".xlsx"
wbNew.Close False
Next
wsData.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox n-1 & " files created in " & foldername, vbInformation
End Sub