Tom’s Tutorials For Excel: Using an InputBox and Looping Dates for Copy and Sum
In January I posted this example for using AutoFilter for dates. AutoFilter is usually quicker and more efficient but I wanted to show how an example of looping through dates by their year.
Here’s a collection of VBA examples, all rolled into this one macro, to demonstrate:
• Using an InputBox with default argument.
• Looping.
• Identifying dates by their year.
• Copying rows to another sheet.
• Programmatically entering a dynamic formula.
In the first picture is a list of sales activity during a mishmash of various years. You provide an InputBox for the user to ferret out any particular year to be copied to Sheet2, and enter a dynamic SUM for the Income, Expense, and Net totals.
The second picture shows a result if year 2010 was entered in the InputBox, with a SUM formula selected that the macro produced.
Here is the macro with explanatory comments in green.
Sub CopyYear()
'Declare a String variable for the Year.
Dim strYear as String
'InputBox to ask for a Year number, default example 2010.
strYear = _
InputBox("Enter the four-digit year:", "Copy a year of data", "2010")
'If no year is entered or Cancel is clicked, exit sub.
If strYear = "" Then
MsgBox "You did not enter a year.", , "Cancelled."
Exit Sub
End If
'If the InputBox entry is not a four-digit number exit sub.
If Len(strYear) <> 4 Or IsNumeric(CStr(strYear)) = False Then
MsgBox "You need to enter a four-digit year," & vbCrLf & _
"example, 2010.", 48, "Not a valid entry."
Exit Sub
End If
'All reasonable precautions are complete.
'Turn off ScreenUpdating.
Application.ScreenUpdating = False
'Declare variables for row, last row, and cell range.
Dim xRow As Long, LastRow As Long, cell As Range
'Define xRow as 2 as the destination first row on Sheet2.
'Row 1 on Sheet2 will have header labels.
xRow = 2
'Open a With structure for Sheet2.
With Sheets("Sheet2")
'Clear all the cells on Sheet2 to start with a clean sheet.
.Cells.Clear
'Put your column headers on row 1 of Sheet2.
.Range("A1:E1").Value = _
Array("Widget ID", "Date", "Income", "Expenses", "Net")
'Open a For Each loop to examine each Constant cell (shorthand #2).
'in column B which is written as Columns(2).
For Each cell In Columns(2).SpecialCells(2)
'First, evaluate for the cell value being a date.
If IsDate(cell.Value) = True Then
'Next, evaluate the date being the same year as entered in the InputBox.
If Year(cell.Value) = strYear Then
'If the evaluations are True, copy that row to the next available row
'in Sheet2 by using the xRow variable.
Rows(cell.Row).Copy .Rows(xRow)
'Add a 1 to the xRow variable to identify the next available row,
'for the next True evaluation.
xRow = xRow + 1
End If
End If
Next cell
'Identify the last row of copied data on Sheet2.
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Enter header labels for totals.
.Range("G1:I1").Value = Array("Income", "Expenses", "Net")
'Place the SUM function in G2 for Income total from column C.
.Range("G2").FormulaR1C1 = "=SUM(R2C3:R" & LastRow & "C3)"
'Place the SUM function in H2 for Expenses total from column D.
.Range("H2").FormulaR1C1 = "=SUM(R2C4:R" & LastRow & "C4)"
'Place the SUM function in I2 for Net total from column E.
.Range("I2").FormulaR1C1 = "=SUM(R2C5:R" & LastRow & "C5)"
'Format G2:I2 as Accounting.
.Range("G2:I2").NumberFormat = _
"_($* #,##0_);_($* (#,##0);_($* ""-""_);_(@_)"
'Autofit the columns on Sheet2 for redability.
.Columns.AutoFit
'Turn ScreenUpdating back on.
Application.ScreenUpdating = True
'Advise the user the macro is completed, or that no rows were copied
'because no dates were found matching the year entered in the InputBox.
If xRow <> 2 Then
MsgBox "All the " & strYear & " rows have been copied" & vbCrLf & _
"to Sheet2, and summed for Income, Expense, and Net.", 64, "Complete."
Else
.Cells.Clear
MsgBox "No cells in column F had dates in year " & strYear & ".", 64, "FYI"
End If
'Close With structure for Sheet2.
End With
End Sub
Marvelous!