Hello all,
As I am sure you'll notice from the clunky code I am self taught and hoping that is why this is running so slowly. The code is doing exactly what I want it to but is taking a long time (~15 to 20 seconds) to run. The basic idea is that users use the filters on the source data tab to identify a set of rows they want to classify, they then use a user form to classify and it is copy and pasted on to an allocations tab.
Any ideas of how I can make this run quicker?
Thank you!!!
Sub CopyPartOfFilteredRange()
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim copyRange As Range
Dim lastRow As Long
Dim lastRow2 As Long
Dim lastRow3 As Long
Dim cell As Range
Set src = ThisWorkbook.Sheets("Source_Data")
Set tgt = ThisWorkbook.Sheets("Allocations")
Application.ScreenUpdating = False
'100% button
If ToggleButton_100 = True Then
TextBox_Allocation.Value = 100
End If
'checks
If TextBox_Allocation.Value = "" And ToogleButton_100 = False Then
MsgBox "You must enter an allocation amount"
ElseIf TextBox_Allocation.Value > 100 Then
MsgBox "The max allocation is 100%"
ElseIf ActiveSheet.Name = "Allocations" Then
MsgBox "Allocations relate to filtered rows on Source_Data tab ONLY"
Else
'removes filters from Allocations tab
Application.Goto tgt.Range("C3")
If (tgt.AutoFilterMode And tgt.FilterMode) Or tgt.FilterMode Then
tgt.ShowAllData
End If
' find the last row with data in column Source_Data Ref
lastRow = src.Range("D" & src.Rows.Count).End(xlUp).Row
' find the last row with data in column Sheet 2 Ref
lastRow2 = tgt.Range("C" & tgt.Rows.Count).End(xlUp).Row
' the range that we are auto-filtering (all columns)
Set filterRange = src.Range("B2:M" & lastRow)
' the range we want to copy (only columns we want to copy)
' we set the range to start in row 3 to prevent copying the header
Set copyRange = src.Range("D3:M" & lastRow)
' filter range Exclusions based on column B <> "Yes"
Application.Goto src.Range("D3")
filterRange.AutoFilter field:=1, Criteria1:=""
' copy the visible cells to tgt ranges last row
copyRange.SpecialCells(xlCellTypeVisible).Copy
tgt.Range("C" & lastRow2 + 1).PasteSpecial (xlPasteValues)
'last row following of tgt sheet following posting
lastRow3 = tgt.Range("C" & tgt.Rows.Count).End(xlUp).Row
'transfer data from userform
tgt.Range("M" & lastRow2 + 1 & ":M" & lastRow3).Value = ListBox_Group.Value
tgt.Range("N" & lastRow2 + 1 & ":N" & lastRow3).Value = ListBox_Sub.Value
tgt.Range("O" & lastRow2 + 1 & ":O" & lastRow3).Value = ListBox_SubSplit.Value
tgt.Range("P" & lastRow2 + 1 & ":P" & lastRow3).Value = ListBox_Plants.Value
tgt.Range("Q" & lastRow2 + 1 & ":Q" & lastRow3).Value = TextBox_Allocation.Value / 100
tgt.Range("R" & lastRow2 + 1 & ":R" & lastRow3).Value = TextBox_Notes.Value
Call Clear_UserForm
'copy sumif formula
tgt.Range("B3:B" & lastRow3).Formula = "=SUMIF($C:$C,C3,$Q:$Q)"
'resets Exclusion flags
For Each cell In src.Range("B3:B" & lastRow)
If Not Application.IsNumber(cell) Then cell.ClearContents
Next cell
AllocationUserForm.Hide
Application.Goto src.Range("D3")
If (src.AutoFilterMode And src.FilterMode) Or src.FilterMode Then
src.ShowAllData
End If
Application.ScreenUpdating = True
End If
End Sub
Bookmarks