I'm a relatively new programmer in VBA for Excel and looking for some help on a work-related project.
The issue at hand is with respect to designing an update routine for a budget tracking system that would update the date entries for any upcoming fiscal year, specified by the user in an input box:
Sub Putittogether()
On Error Resume Next
Dim xMonthNumber As Integer
Dim xMonthNumber2 As Integer
Dim xYearInput As Integer
Dim xCell As Range
Dim xCell2 As Range
Dim xMonthYear As Range
Dim xMonthNextYear As Range
Set xMonthYear = Range("B4:B12")
Set xMonthNextYear = Range("B1:B3")
xYearInput = InputBox("Please enter year:")
For Each xCell In xMonthYear
xCell = xYearInput
For xMonthNumber = 4 To 12
Range("B" & xMonthNumber).NumberFormat = "General"
Range("B" & xMonthNumber) = MonthName(xMonthNumber, True) & xCell
For Each xCell2 In xMonthNextYear
xCell2 = xYearInput + 1
For xMonthNumber2 = 1 To 3
Range("B" & xMonthNumber2).NumberFormat = "General"
Range("B" & xMonthNumber2) = MonthName(xMonthNumber2, True) & xCell2
Next xMonthNumber2
Next xCell2
Next xMonthNumber
Next xCell
End Sub
The macro goes from April of the current year to March of the following year, thus the double loops.
I run into issues in two places: using the method I'm using, the ranges in the B column need to be strictly reflected in rows 1-12 and any other rows causes problems with the output, and I'm not sure why.
The second issue is that I've got tracking totals tables for every month and trying to run this macro in a table that has a header row (i.e. shifts the first data row to B2) creates additional output problems - so, how do I make it work in a different range?
Thank you in advance for your help!!
Couldn't you use the Date data type and then the DateAdd() function. This would simplify your loop to just two lines of code.
If you need to stipulate a start row then one way would be to run the row loop from startRow to startRow + 11.
So your code would look something like this:
Const START_ROW As Integer = 1 'set this to the row you want
Dim ws As Worksheet
Dim r As Integer
Dim dat As Date
Dim yyyy As Integer
Set ws = ThisWorkbook.Worksheets("Sheet1")
yyyy = InputBox("Please enter year:")
dat = DateSerial(yyyy, 4, 1)
For r = START_ROW To START_ROW + 11
ws.Cells(r, "B").Value = Format(dat, "mmmyyyy")
dat = DateAdd("m", 1, dat)
Next
May be you can use this code
Sub Putittogether()
On Error Resume Next
Dim xYearInput As Integer
Dim xColumn As Integer
Dim xDate As Date
xYearInput = InputBox("Please enter year:")
xDate = DateSerial(xYear,4,1) 'you might adjust this date to the first month to be entered
For xColumn = 1 to 12
Cells("B" & xColumn ).NumberFormat = "General"
Cells("B" & xColumn ) = Format(xDate,"MMM YY")
xDate = DateAdd("m", 1, xDate)
Next xColumn
End Sub
Related
I'm having the following columns in Excel: Document Date (all cells have values) & Initial Disposition Date (there're blanks within the column).
Each Document Date cell corresponds to an Initial Disposition Date cell.
For any blank Initial Disposition Date cells, I'd like to set them to be 7 days from the corresponding Document Date. (Strictly blank cells)
Ex: Document Date = 10/01/2018. Desired Initial Disposition Date = 10/08/2018.
Is there a code to execute such action? (I have approximately 55,000 rows and 51 columns by the way).
Thank you very much! Any suggestions or ideas are highly appreciated!
Looping through a range is a little quicker in this case. I am assuming your data is on Sheet1, your Document Date is on Column A and your Initial Deposition is on Column B.
Last, you need to determine if you want that 7 days to be inclusive of weekends or not. I left you a solution for both. You will need to remove one of the action statements (in middle of loop)
Option Explicit
Sub BetterCallSaul()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LRow As Long, iRange As Range, iCell As Range
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set iRange = ws.Range("B2:B" & LRow)
Application.ScreenUpdating = False
For Each iCell In iRange
If iCell = "" Then
iCell = iCell.Offset(, -1) + 7 'Includes Weekends
iCell = WorksheetFunction.WorkDay(iCell.Offset(, -1), 7) 'Excludes Weekends
End If
Next iCell
Application.ScreenUpdating = True
End Sub
If your Document Date is on Column A and you Initial Disposition Date in Column B, then the following would achieve your desired results:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To Lastrow
'loop from row 2 to the last row with data
If ws.Cells(i, "B").Value = "" Then
'if there is no value in Column B then
ws.Cells(i, "B").Value = ws.Cells(i, "A").Value + 7
'add seven days to the date from Column A
End If
Next i
End Sub
A formula on all blanks would avoid the delays looping through the worksheet column(s).
Sub ddPlus7()
Dim dd As Long, didd As Long
With Worksheets("sheet1")
'no error control on the next two lines so those header labels better be there
dd = Application.Match("Document Date", .Rows(1), 0)
didd = Application.Match("Desired Initial Disposition Date", .Rows(1), 0)
On Error Resume Next
With Intersect(.Columns(dd).SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, _
.Columns(didd).SpecialCells(xlCellTypeBlanks).EntireRow, _
.Columns(didd))
.FormulaR1C1 = "=rc[" & dd - didd & "]+7"
End With
On Error GoTo 0
End With
End Sub
I am working on a macro that assigns values based on matches between dates. My macro is supposed to loop through a column of dates and match the month-year of each date to a row with other dates. If there is a match, a value in a corresponding column needs to be copies over. The issues I am running into is comparing an extracted month-year of one date with the month-date of another. A simple version of what I want the data to look like is this:
As you can see, the value is copied over into the horizontal part that corresponds to the date next to the value. It is copied over a fixed number of times depending on the term.
The issue I am running into is in matching the date. I am trying to compare the month-year of the Date with the month-year in row 1, but my script is only functioning when there is an exact match, i.e. when the date in column B matches the date in row 1. So if a date in column B is 1/1/2011, then it gets copied into the correct cell, but otherwise it does not get copied at all. Here is the script I am working on (note that I only have it set up for quarterly terms - when I get that to work, I will add the other terms to the If-statement.
Sub End_Collate()
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wb As Workbook
Dim lastrow As Long, lastcolumn As Long, lastrow_reps As Long
Dim reps As Variant, reps_list As Variant
Dim min_date As Date, min_date_format As Date, date_diff As Integer
Dim cell As Range
Set wb = ActiveWorkbook
Set ws2 = wb.Sheets("data")
Set ws = wb.Sheets("Rep_Commission")
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set reps_list = ws.Range("A3:A" & (lastrow))
date_diff = DateDiff("m", min_date, Date)
'loop through each sheet and add in the correct dates to the correct range
For Each reps In reps_list
min_date = Application.WorksheetFunction.Min(ws2.Range("H2:H" &
Cells(Rows.Count, 1).End(xlUp).Row))
i = 0
With wb.Worksheets(reps.Text)
Do While DateDiff("m", min_date, Date) <> 0
Worksheets(reps.Text).Range("S1").Offset(0, i).Value = min_date
min_date = DateAdd("m", 1, min_date)
i = i + 1
Loop
End With
Next reps
For Each reps In reps_list
i = 0
j = 0
lastrow_reps = Worksheets(reps.Text).Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = Worksheets(reps.Text).Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To lastrow_reps
'currently this is quarterly - once I get it to work I will add options for daily, monthly etc.
If Worksheets(reps.Text).Cells(i, 11).Value = "Quarterly" Then
With Worksheets(reps.Text)
For j = 18 To lastcolumn
If (DatePart("m", .Cells(i, 8)) & DatePart("y", .Cells(i, 8))) = (DatePart("m", .Cells(1, j)) & DatePart("y", .Cells(1, j))) Then
.Cells(i, j) = .Cells(i, 18)
Else 'Do nothing (will add error handling here)
End If
Next j
End With
End If
Next i
Next reps
End Sub
You're using the wrong interval for DatePart (the documentation is here).
"y" is the day of the year, not the year. Your code looks like it should work if you replace the interval with "yyyy".
This demonstrates:
Public Sub DatePartIntervals()
Debug.Print DatePart("y", Now)
Debug.Print DatePart("yyyy", Now)
End Sub
I have an range of input like shown on image 1. If i give an Start date and end date on the another sheet, the vba will run through and i need to get output like shown in the image 2. I can specify any date as a range of date in the next sheet. There is duplication of date in the range of inputs. How to give date loop for this scenario and remove duplicates in the name to add the time and get the desired output.
`
Sub dateloop()
Dim sd As Date
Dim ed As Date
Dim asd As Range
sd = Sheets(1).Range("b2") .Value
ed = Sheets(1).Range("b3").Value
For asd = sd To ed
MsgBox asd.Value
Next asd
End Sub `
I tried the above code but it didn't loop through the range of dates.
Sub looprange()
Dim MyRange As Range
Dim MyCell As Range
Set MyRange = Sheets("input").Range("A1:a40000")
For Each MyCell In MyRange
If MyCell.Value >= Sheets("output").Range("b2").Value And _
MyCell.Value <= Sheets("output").Range("b3").Value Then
Sheets("output").Range("b5").offset(1,0) = Mycell.offset(0,1).Value
End If
Next x
End Sub
I tried above coding also but i didn't worked. Can someone help me to get the Output.
Input:
Output:
Combine Unique Values Based Off Two Criteria
The Code
Option Explicit
'Option Explicit is very helpful because it will throw an error on compile if
'you have undefined variables floating around in your project.
Sub LoopRange()
Application.ScreenUpdating = False 'Faster runtime
Dim iWS As Worksheet: Set iWS = ThisWorkbook.Sheets("Input")
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Sheets("Output")
Dim inputRange As Range: Set inputRange = iWS.Range("A3", iWS.Range("A3").End(xlDown))
Dim outputRange As Range: Set outputRange = oWS.Range("A6", oWS.Range("A6").End(xlDown))
Dim fullOpRange As Range
Dim startDate As Date: startDate = oWS.Range("B2").Value
Dim endDate As Date: endDate = oWS.Range("B3").Value
Dim cRow As Long: cRow = 5
Dim oRow As Long: oRow = 7
Dim iCell As Range, oCell As Range
'Build the output range on the Output worksheet that falls between defined dates.
For Each iCell In inputRange
If iCell.Value >= startDate And iCell.Value <= endDate Then
cRow = cRow + 1
oWS.Range("A" & cRow).Value = iCell.Offset(0, 1).Value
oWS.Range("B" & cRow).Value = iCell.Offset(0, 2).Value
oWS.Range("C" & cRow).Value = iCell.Offset(0, 3).Value
End If
Next iCell
Set fullOpRange = oWS.Range("A5:C" & oWS.Cells(Rows.Count, 3).End(xlUp).Row)
'Sort the output range
fullOpRange.Sort oWS.Range("A6"), xlAscending, oWS.Range("B6"), , xlAscending, Header:=xlYes
fullOpRange.Borders.LineStyle = xlContinuous
'Add duplicate matching Name/Type and delete excess
Do
If oWS.Range("A" & oRow).Value = oWS.Range("A" & oRow - 1).Value And oWS.Range("B" & oRow).Value = oWS.Range("B" & oRow - 1).Value Then
oWS.Range("C" & oRow - 1).Value = oWS.Range("C" & oRow - 1).Value + oWS.Range("C" & oRow).Value
oWS.Range("A" & oRow).EntireRow.Delete xlUp
Else
oRow = oRow + 1
End If
Loop While oRow <> oWS.Cells(Rows.Count, 3).End(xlUp).Row + 1
Application.ScreenUpdating = True 'Do not forget to turn this back on!
End Sub
Explanation
The first thing I did was transfer the applicable data that falls between the desired dates, from the Input worksheet to the Output worksheet.
Next I wanted to sort this data by Name and Type to make cycling through the output range faster.
After that it's as simple as comparing the current row's data to the previous row, and looping through to the end.
Comments with a mini-answer
The above code should function in the way you desire. There's a lot more room for expanding on this code to make it more user friendly for multiple uses, but I'll leave that to you. It seems like you may not have a grasp of the basics and if this is true, I strongly suggest reading up on a few tutorials that cover expressions you want to use. It will save you a lot of time and headache if you can get a good understanding of basic programming expressions.
As an example, you said that the following code did not loop through your range of dates. I included comments to help you see why this wouldn't work with your structure of For Loop:
Sub dateloop()
Dim sd As Date
Dim ed As Date
Dim asd As Range
sd = Sheets(1).Range("b2").Value
ed = Sheets(1).Range("b3").Value
For asd = sd To ed 'For Range = Date To Date
MsgBox asd.Value 'MsgBox Range.Value (Range was never defined)
Next asd 'Next Range
End Sub
The way you're trying to use the For Loop is incorrect. The following code works but doesn't really help you achieve your end goal:
Sub dateloop()
Dim sd As Date
Dim ed As Date
Dim asd As Date '<----Date
sd = Sheets(2).Range("b2").Value
ed = Sheets(2).Range("b3").Value
For asd = sd To ed 'For Date = Date To Date
MsgBox asd '<----remove .Value
Next asd
End Sub
A different way to approach the For Loop that is more useful to your project:
Sub dateloop()
Dim sd As Date
Dim ed As Date
Dim asd As Range '<----Range
sd = Sheets(2).Range("b2").Value
ed = Sheets(2).Range("b3").Value
For Each asd In Sheets(1).Range("A3:A20") 'For Each Range in Range
If asd.Value >= sd And asd.Value <= ed Then _
MsgBox asd.Value
Next asd
End Sub
I hope this helps. If you have any questions on what the code I provided is doing, or if there are any issues with it, please let me know. Good luck!
I'm trying to write an Excel macro that will look at the dates in column A and print each month listed in a column F. I am trying to use a for loop and If/Else statements but I can't seem to get it to work out correctly.
y = 2
Range("F2").Formula = "=MONTH(A3)"
For x = 4 To RowLast - 1
If Range("A" & x).Month = Range("F" & y) Then
Else
y = y + 1
Range("F" & y).Formula = "=MONTH(A" & x & ")"
End If
Next
That is what I have thus far and it should print the first month found in Cell A3 to Cell F2 (which works), then go through every other date until it hits one line above the last. The if statements should check to make sure it's a new month and if it is print the month to the next cell in column F.
Please let me know if you have any questions. Thank you.
I think your if statement is causing the problems. Do you even need an if statement here if you are just printing the month?
RowLast = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
y = 2
Range("F2").Formula = "=MONTH(A3)"
For x = 4 To RowLast - 1
Range("Z2").Formula = "=MONTH(A" & x & ")"
If Range("Z2").Value = Range("F" & y).Value Then
Else
y = y + 1
Range("F" & y).Formula = "=MONTH(A" & x & ")"
End If
Next
To answer your specific question: Month(date) is a function that returns an integer corresponding to the month of the date argument. So Month(Now) would return 3, for example.
.Month is not a property of the .Range object so your code would throw an error ("Object doesn't support this property or method"). The code below shows how to use the Month() function in the way you want.
However, your code poses a wider question. Are you using VBA merely to automate your formula writing? If you are, then all well and good. But is it possible that you are using worksheet functions when, actually, VBA would serve you better? Is there a reason, for example, that you would use VBA to identify target months only to write those target months to your worksheet by way of an Excel formula?
I mention it because quite a few posts recently have limited their scope to how to automate Excel functions (probably as a result of recording macros) whereas VBA can be more capable than their imagination might allow.
Anyhow, here are two very similar versions of the same task: the first that writes the formulae and the second that writes the months. I hope it'll provoke some thought as to which automation type suits your needs:
Code to write the formulae:
Public Sub FormulaGenerator()
Dim ws As Worksheet
Dim firstRow As Long
Dim lastRow As Long
Dim dateRange As Range
Dim cell As Range
Dim hitList As Collection
Dim refMonth As Integer
Dim thisMonth As Integer
Dim r As Long
Dim output() As Variant
Dim item As Variant
'Set these for your own task.
Set ws = ThisWorkbook.Worksheets("Sheet1")
firstRow = 3
lastRow = 20
'Read the values cell by cell
Set dateRange = ws.Range(ws.Cells(firstRow, "A"), ws.Cells(lastRow, "A"))
Set hitList = New Collection
For Each cell In dateRange.Cells
item = cell.Month
thisMonth = Month(cell.Value)
If thisMonth <> refMonth Then
'It's a new month so populate the collection with the cell address
hitList.Add cell.Address(False, False)
refMonth = thisMonth
End If
Next
'Populate the output array values
ReDim output(1 To hitList.Count, 1 To 1)
r = 1
For Each item In hitList
output(r, 1) = "=MONTH(" & item & ")"
r = r + 1
Next
'Write the output array starting at cell "F2"
ws.Cells(2, "F").Resize(UBound(output, 1)).Formula = output
End Sub
Code to write the months as integers:
Public Sub OutputGenerator()
Dim ws As Worksheet
Dim firstRow As Long
Dim lastRow As Long
Dim dates As Variant
Dim hitList As Collection
Dim refMonth As Integer
Dim thisMonth As Integer
Dim r As Long
Dim output() As Integer
Dim item As Variant
'Set these for your own task.
Set ws = ThisWorkbook.Worksheets("Sheet1")
firstRow = 3
lastRow = 23
'Read the dates into an array
dates = ws.Range(ws.Cells(firstRow, "A"), ws.Cells(lastRow, "A")).Value
'Loop through the array to acquire each new date
Set hitList = New Collection
For r = 1 To UBound(dates, 1)
thisMonth = Month(dates(r, 1))
If thisMonth <> refMonth Then
'It's a new date so populate the collection with the month integer
hitList.Add thisMonth
refMonth = thisMonth
End If
Next
'Populate the output array
ReDim output(1 To hitList.Count, 1 To 1)
r = 1
For Each item In hitList
output(r, 1) = item
r = r + 1
Next
'Write the output array starting at cell "F2"
ws.Cells(2, "F").Resize(UBound(output, 1)).Value = output
End Sub
I have a unique situation not covered by an other article I can find here. I have a workbook of tens of thousands of lines, but they're all essentially like this:
There's a whole lot of "stuff" going on in the workbook and data is constantly added, but the crux of my issue is that I need a piece of code to be able to keep a certain number of the most recent instances of the data (let's say 2) and remove the rest. I don't deal with dates in VBA very often so I wish I could "show my work" thus far, but I truly don't know where to start.
In plain English: Count the number of unique dates in column D. If that number is > 2, THEN delete rows where the date is older than the 2 most recent dates.
Again, I apologize for not having any work to show thus far. I truly have "writers' block" on this one. Any help is appreciated!
UPDATE: With the help in the comments I've written the following to do the first step of finding the 2nd most recent date on my real data sheet (35000+ rows) where the date column is P. I must be doing something wrong because as I track the value of OldMax in the locals window it only returns the most recent date no matter what I put in for the number in Large(DateRange,whatever number). Hmmmmm....
Sub Remove_Old_Data()
Dim wks As Worksheet
Dim OldMax As String
Dim DateRange As Range
Dim lrow As Long
Set wks = ThisWorkbook.Worksheets("X-AotA")
lrow = wks.Cells(Rows.Count, "P").End(xlUp).Row
Set DateRange = wks.Range("P2:P" & lrow)
OldMax = Application.WorksheetFunction.Large(DateRange, 2)
End Sub
I tested the code below and it works. Should be fairly easy to understand, but I basically just loop through all the rows to determine what the 2 most recent dates are and then loop through all the rows again, deleting any rows that do not contain either of those dates.
Sub Remove_Old_Data()
On Error GoTo 0
Dim vSheet As Worksheet
Dim vRange As Range
Dim vRow As Long
Dim vRowFirst As Long
Dim vRowLast As Long
Dim vCol As Long
Dim vCurDate As Date
Dim vTopDate1 As Date
Dim vTopDate2 As Date
Set vSheet = ThisWorkbook.Worksheets("X-AotA")
Set vRange = vSheet.UsedRange
'Set vCol to column P
vCol = 17 - vRange.Column
'Set the rows to scan through
vRowFirst = 2
vRowLast = vRange.Rows.Count
If vRowLast < 4 Then Exit Sub
'Determine what the biggest 2 dates are
vTopDate1 = DateValue("1900-01-01")
vTopDate2 = DateValue("1900-01-01")
For vRow = vRowFirst To vRowLast
vCurDate = DateValue("1900-01-01")
On Error Resume Next
vCurDate = DateValue(vRange(vRow, vCol).Value)
On Error GoTo 0
If vCurDate > vTopDate1 Then
vTopDate2 = vTopDate1
vTopDate1 = vCurDate
ElseIf vCurDate > vTopDate2 And vCurDate <> vTopDate1 Then
vTopDate2 = vCurDate
End If
Next
'Loop through the rows again and remove any that do not contain the top 2 dates
vRow = vRowFirst
Do While vRow <= vRowLast
vCurDate = DateValue("1900-01-01")
On Error Resume Next
vCurDate = DateValue(vRange(vRow, vCol).Value)
On Error GoTo 0
If vCurDate <> vTopDate1 And vCurDate <> vTopDate2 Then
'Remove this row
vRange.Cells(vRow, 1).EntireRow.Delete
vRowLast = vRowLast - 1
Else
'Continue to the next row
vRow = vRow + 1
End If
Loop
End Sub
I ended up using the following because I only used "keep 2 most recent dates" as a simplified example. I'm actually keeping the 12 most recent dates so the other proposed answer would get pretty cumbersome. Here is what I came up with.
Sub Scrub_Old_Data()
Dim iUnique As Long
Dim Wks As Worksheet
Dim LastRow As Long
Dim i As Long
Dim OldDateKeep As Long
OldDateKeep = ThisWorkbook.Worksheets("X-User Input").Range("B11").Value
Set Wks = ThisWorkbook.Worksheets("X-AotA")
'find the last row of data
LastRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
'make sure the right worksheet is being analyzed
Wks.Select
'check the entire sheet to see if we even have more than 12 unique dates. If not, do nothing
iUnique = Evaluate("=SUMPRODUCT(1/countif(P2:P" & LastRow & ",P2:P" & LastRow & "))")
If iUnique > OldDateKeep Then
With Wks
'sort in descending date order
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields. _
Add Key:=Range("P1:P" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
i = 2
Do Until IsEmpty(Cells(i, 16))
If Evaluate("=SUMPRODUCT(1/countif(P1:P" & i & ",P1:P" & i & "))") - 1 > OldDateKeep Then
Cells(i, 16).EntireRow.Delete
Else
i = i + 1
End If
Loop
End If
End Sub