Sub CopyStuff() Application.ScreenUpdating = False With ActiveSheet .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "C" On Error Resume Next .Offset(1).EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1) End With .AutoFilterMode = False End With Application.ScreenUpdating = True Sheet2.Select End Sub
Sub TransferAllData() Application.ScreenUpdating = False Dim lRow As Long Dim MySheet As String lRow = Range("A" & Rows.Count).End(xlUp).Row On Error Resume Next For Each cell In Range("A2:A" & lRow) MySheet = cell.Value cell.EntireRow.Copy Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) Sheets(MySheet).Columns.AutoFit Next cell Columns(1).SpecialCells(4).EntireRow.Copy Sheets("Unassigned").Range("A" & Rows.Count).End(xlUp).Offset(1) Sheets("Unassigned").Columns.AutoFit MsgBox "Data transfer completed!", vbExclamation Application.ScreenUpdating = True Application.CutCopyMode = False End Sub
Sub FindIDValues() FindBlanks Application.ScreenUpdating = False Dim IDSearch As String IDSearch = Sheets("Master").Range("B1") With Sheets("Master") .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, IDSearch .Offset(1).EntireRow.Copy Sheets(IDSearch).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With Sheets(IDSearch).Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False Sheets("Master").Range("B1") = "Enter Search ID" Sheets(IDSearch).Select End Sub Sub FindBlanks() Application.ScreenUpdating = False Sheets("Unassigned").UsedRange.Offset(1).ClearContents With Sheets("Master") .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "" .Offset(1).EntireRow.Copy Sheets("Unassigned").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With Sheets("Unassigned").Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False End Sub
Sub FindStuff() FindStuff2 FindStuff3 FindStuff4 Application.ScreenUpdating = False Sheets("Unassigned").UsedRange.Offset(1).ClearContents With Sheets("Master") .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "" .Offset(1).EntireRow.Copy Sheets("Unassigned").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With Sheets("Unassigned").Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False MsgBox "All done!", vbExclamation End Sub Sub FindStuff2() Application.ScreenUpdating = False 'Sheets("CB").UsedRange.Offset(1).ClearContents With Sheets("Master") .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "CB" .Offset(1).EntireRow.Copy Sheets("CB").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With Sheets("CB").Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False End Sub Sub FindStuff3() Application.ScreenUpdating = False 'Sheets("SC").UsedRange.Offset(1).ClearContents With Sheets("Master") .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "SC" .Offset(1).EntireRow.Copy Sheets("SC").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With Sheets("SC").Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False End Sub Sub FindStuff4() Application.ScreenUpdating = False 'Sheets("IA").UsedRange.Offset(1).ClearContents With Sheets("Master") .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "IA" .Offset(1).EntireRow.Copy Sheets("IA").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With Sheets("IA").Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False End Sub
So, every time I click the "transfer data" button, will it add to the existing items or will it rerun itself to update the worksheets?
I'm not sure if you wanted the transferred data in each individual sheet cleared before new data is transferred so I have commented out those lines of code in the above macro (the green print). If you need the data cleared, just remove the apostrophe from the begining of each green line of code.
Sub ArchiveStuff() Application.ScreenUpdating = False With Sheets("Master") .AutoFilterMode = False On Error Resume Next With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, "Completed" .Offset(1).EntireRow.Copy Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues .Offset(1).EntireRow.Delete End With .AutoFilterMode = False End With Sheets("Completed").Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False Sheets("Completed").Select End Sub
Option Explicit Sub MoveStuff() Dim ar As Variant, I As Integer ar = [{"CB","SC","IA","Unassigned";"CB","SC","IA",""}] Application.ScreenUpdating = False For I = 1 To UBound(ar, 2) Sheets(ar(1, i)).UsedRange.Offset(1).ClearContents With Sheet6 'Shee6 is the Master sheet (sht code name - gold) .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, ar(2, i) .Offset(1).EntireRow.Copy Sheets(ar(1, i)).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues ActiveSheet.AutoFilterMode = False Sheets(ar(1, i)).Columns.AutoFit End With End With Next i Application.ScreenUpdating = True Application.CutCopyMode = False MsgBox "All done!", vbExclamation End Sub