We value your feedback.
Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
Sub CommandButton1_Click() Dim i As Long, lastRow As Long Dim rRow As Long, cCol As Long Dim mMonth As Long Dim yYear As Long Dim rng As Range Dim wb1 As Workbook Dim Dept As String '~~> Change the range to the relevant range here If Intersect(Selection, Range("r8:u13")) Is Nothing Then 'the intersect function checks to see if the selection exists in the given range MsgBox "Please select the cell in the correct range" Exit Sub End If Application.ScreenUpdating = False 'Sheets("QB_Expenses").Activate lastRow = Sheets("QB_Expenses").Range("A" & Rows.Count).End(xlUp).Row ' finds last row in QB_Expenses Worksheet 'This part tells the macro which dept/month combination we are working with rRow = Selection.Row cCol = Selection.Column mMonth = Month(Cells(7, cCol).Value) 'What month are we looking for? yYear = Year(Cells(7, cCol).Value) 'The month columns are all in row 7 Dept = Cells(rRow, 14).Value 'What Dept are we looking for 'The Departments rows are all in column 14 Set rng = Sheets("QB_Expenses").Range("A1:G1") 'On Error GoTo ErrorCatch For i = 2 To lastRow If Month(Sheets("QB_Expenses").Range("C" & i).Value) = mMonth _ And _ Year(Sheets("QB_Expenses").Range("C" & i).Value) = yYear _ And _ Sheets("QB_Expenses").Range("D" & i).Value = Dept Then Set rng = Union(rng, Sheets("QB_Expenses").Range("A" & i & ":G" & i)) 'if the month, year, and dept match, add this row to the open workbook End If Next i Sheets("QB_Expenses").Range(rng.Address).Copy Set wb1 = Workbooks.Add wb1.Sheets(1).Activate ActiveSheet.Paste '~~> Change the file Name Here 'wb1.SaveAs "\\adpsfs\Accounting\Bobby\MyFile.xls" 'Call fitWidth Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Join the community of 500,000 technology professionals and ask your questions.