Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Autofiltering & copying results to new worksheet - custom message box
Good afternoon!
I've been using Ron de Bruin's code below to perform an auto filter on one worksheet and copy/paste the results into another sheet. The auto filter, when run, will display a message box in which the user will input the auto filter criteria. This works perfectly, however, I need to make one small change...I need to provide a combo box with preset (they will not change) options to choose from, rather than a blank space to type in the filter criteria. My current code is below. Option Explicit Sub CreateMarketingElectionReport() 'Note: This macro use the function LastRow 'Important: The DestSh must exist Dim My_Range As Range Dim DestSh As Worksheet Dim CalcMode As Long Dim ViewMode As Long Dim FilterCriteria As String Dim CCount As Long Dim rng As Range 'Set filter range Set My_Range = Worksheets("Marketing Elections").Range("A4:Z" & LastRow(Worksheets("Marketing Elections"))) 'Set the destination worksheet Set DestSh = Sheets("Marketing Election Report") If ActiveWorkbook.ProtectStructure = True Or My_Range.Parent.ProtectContents = True Then MsgBox "Sorry, that feature is not available when the workbook is protected.", vbOKOnly, "Copy to new worksheet" Exit Sub End If 'Change ScreenUpdating, Calculation, EnableEvents, .... With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView ActiveSheet.DisplayPageBreaks = False 'Firstly, remove the AutoFilter My_Range.Parent.AutoFilterMode = False 'If you want to filter on a Inputbox value use this FilterCriteria = InputBox("What type of election do you need info for?", _ "Enter election type") If FilterCriteria = "" Then Exit Sub FilterCriteria = Replace(FilterCriteria, "*", "") FilterCriteria = "*" & FilterCriteria & "*" My_Range.AutoFilter Field:=22, Criteria1:="=" & FilterCriteria 'Check if there are not more then 8192 areas(limit of areas that Excel can copy) CCount = 0 On Error Resume Next CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible ).Areas(1).Cells.Count On Error GoTo 0 If CCount = 0 Then MsgBox "There are more than 8192 areas:" _ & vbNewLine & "It is not possible to copy the visible data." _ & vbNewLine & "Tip: Sort your data before you use this macro.", _ vbOKOnly, "Copy to worksheet" Else 'Copy the visible data and use PasteSpecial to paste to the Destsh With My_Range.Parent.AutoFilter.Range On Error Resume Next ' Set rng to the visible cells in My_Range without the header row Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _ .SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not rng Is Nothing Then 'Copy and paste the cells into DestSh below the existing data rng.Copy With DestSh.Range("A" & LastRow(DestSh) + 1) ' Paste:=8 will copy the columnwidth in Excel 2000 and higher ' Remove this line if you use Excel 97 '.PasteSpecial Paste:=8 .PasteSpecial xlPasteValues ' .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With 'Delete the rows in the My_Range.Parent worksheet 'rng.EntireRow.Delete End If End With End If 'Close AutoFilter 'My_Range.Parent.AutoFilterMode = False My_Range.Parent.ShowAllData 'Restore ScreenUpdating, Calculation, EnableEvents, .... With Application .EnableEvents = True .Calculation = CalcMode Dim endrange As Long End With Call CopyMarketingElectionReport End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
subtotals with custom autofiltering | Excel Discussion (Misc queries) | |||
Autofiltering and copying selection to anotherworkbook | Excel Programming | |||
Searching a workbook and copying results to new worksheet | Excel Discussion (Misc queries) | |||
Copying a region in excel results in the entire worksheet being pa | Excel Worksheet Functions | |||
Copying RESULTS of a FORMULA to another worksheet | Excel Programming |