I have a macro that I am currently running on two different workbooks, however it is giving me the above error on one workbook only. Through trial and error, I'm learning that it's working when I am sorting smaller batches of data, but when I attempt to sort data (5000+), the workbook stops responding and gives me that error pop-up.
The purpose of the macro is to distribute data into different named tabs based off of the fourth column. The user selects the information they want to be sorted and the macro does the rest. Is there a better way to do this so that it can handle 10000+ rows of data?
Sub Disperse_Data()
For Each myCell In Selection.Columns(4).Cells
If myCell.Value = "400" Then
myCell.EntireRow.Copy Worksheets("SU400").Range("A" & Rows.Count).End(3)(2)
End If
Next
The Next triggers the next instance, where the value is a different number and the worksheet is a different name. Thank you all for your help!
I have tried rewriting the macro, copying the macro from the other workbook into this one, verifying all data is the proper data (numbers where numbers are expected, etc.) Each attempt had the same results. I was expecting/hoping for it to just work.
Using Autofilter
Option Explicit
Sub Disperse_Data()
Dim wb As Workbook, wsData As Worksheet, ws As Worksheet
Dim rngData As Range, n As Long, lastrow As Long
Dim s As String, c As Long, r as Long
Dim t0 As Single: t0 = Timer
' check selection
If Selection.Column <> 4 Then
MsgBox "Select column D", vbCritical
Exit Sub
ElseIf vbNo = MsgBox(Selection.Rows.Count & " rows selected, OK", _
vbYesNo, "Confirm") Then
Exit Sub
End If
Set wsData = Selection.Parent
With wsData
Set rngData = Intersect(Selection, .UsedRange)
' last column
c = .UsedRange.Column + .UsedRange.Columns.Count - 1
'MsgBox rngData.Address & " " & c
End With
' copy
Application.ScreenUpdating = False
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If ws.Name Like "SU4##" Then
s = Right(ws.Name, 3)
'ws.Cells.Clear
r = 1 + ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
With rngData.Offset(, -3).Resize(, c)
.AutoFilter 4, s
.SpecialCells(xlCellTypeVisible).Copy _
ws.Range("A" & r)
.AutoFilter
n = n + 1
End With
' remove header
If ws.Range("D" & r) <> s Then ws.Rows(r).Delete
End If
Next
Application.ScreenUpdating = True
MsgBox n & " sheets updated", vbInformation, _
Format(Timer - t0, "0.0 secs")
End Sub