My code below has two parts. The first part basically sets a cell as a date that is 6 months from now. This part works but I'm having trouble with the second part.
The second part is after filtering a table, I want to compare each cell in column H (which is a date value) with that future date in the first part. If the date in column H is after the future date, cell AI of that row will be set as "Yes"
Set Database = ThisWorkbook.Worksheets("Sheet1")
Dim i As Long, LastRow As Long
LastRow = Database.Cells(Rows.count, "A").End(xlUp).Row
With Database.Range("AI1")
'Adds 6 months to today's date in cell AI1 in sheet
.Formula = "=EDATE(Today(),6)"
'Converts that date to 1st day of the month (e.g. 17/01/2020 is converted to 01/01/2020
.Value = DateSerial(Year(Range("AI1")), Month(Range("AI1")), 1)
End With
For i = 2 To LastRow
'This line throws a run-time error 13: type mismatch
If Cells(i, "H").SpecialCells(xlCellTypeVisible) > Database.Range("AI1") Then
Cells(i, "AI").Value = "Yes"
End If
Next i
Below should work, with the note that it could replace the value in AI1 on the first loop iteration. Not sure you really want that?
Dim c As Range, vis As Range, dt as Date
'calculate cutoff date
dt = Application.EDate(Date, 6)
dt = DateSerial(Year(dt), Month(dt), 1)
On Error Resume Next 'ignore error if no visible cells
Set vis = database.Range("H1:H" & LastRow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0 'stop ignoring errors
If Not vis Is Nothing Then 'any visible cells ?
For Each c In vis.Cells
If c.Value > dt Then c.EntireRow.Range("AI1").Value = "Yes"
Next c
End If
Related
I am trying to return a list of dates within 30 days of a given day. For example, I want to be able to input todays date and I want excel to search a separate table, with multiple columns of dates. If it finds one within 30 days of today, AND the value of the cell to the left of the date reads "no", then I want it to return the date, the row, and the column.
My initial thought is to define the range of the table and loop through the cells. Then add an if statement that compares each cell with today's date. If they're within 30 days, it will check the value to the left with another if statement. If the value to the left reads no, then it will assign variable = cell value, row number, column number.
In theory, this will leave me with a list of variables that are my matches. Then, all I have to do it report the list of variables in a cell. My vba skills are basic so I need help with the actual diction.
***Update
At this point I'm just trying to get a working loop:
Sub GenerateReport()
'must have selection to work
'Application.DisplayAlerts = True
Dim rng As Range
Dim i As Integer
Dim TD() As Variant
ReDim TD(Selection.Cells.Count)
i = 1
For Each rng In Selection
If IsDate(Cell.Value) Then
If Abs(CDate(Cell.Value) - SearchDate) <= 30 And LCase(Cell.Offset(0, -1).Value) = "no" Then
TD(i) = Cell.Value
Else
TD(i) = 0
i = i + 1
End If
End If
Next
End Sub
I would expect to get a list of 1s and 0s from this, but I can't get it to run.
You could do something along these lines:
Sub GenerateReportFromSelection()
Dim c As Range, col As New Collection, v
For Each c In Selection.Cells
If c.Column > 1 Then 'make sure you can offset one col to left...
v = c.value 'read the value once
If IsDate(v) Then
If Abs(CDate(v) - Date) <= 30 And _
LCase(c.Offset(0, -1).value) = "no" Then
col.Add c 'add cell to collection
End If '30 days + no
End If 'is a date
End If 'col>1
Next
'review the hits
Debug.Print "---Matches---"
For Each c In col
Debug.Print c.value, c.Row, c.Column
Next c
End Sub
I'm sure this is possible, im just not sure what the code should be. i have 2 sheets: (1)Component which has all the Component Names where an analyst got marked down on, including dates of when the call occurred, and (2)Calculator, which counts the number of times a specific component appeared in a specific week number.
ive created a code which gets the distinct Component Names from the Component Sheet, and then copies and transpose them to the Calculator sheet. all the Component Names are in Row 1 starting from Column D1 then goes to E1, F1, and so on. i want row 2 to display the count or the number of times the component(listed in row 1) appeared in a week.
The code i have only works for columns, i do not know how to make it get the non-empty values of an entire row.
'//here the code i used to transpose Distinct Components from the Component sheet to the Calculator Sheet
Public Sub GetDistinctComponents()
Application.ScreenUpdating = False
Dim lr As Long
lr = Sheets("Components Data").Cells(Rows.Count, "F").End(xlUp).Row
Sheets("Calculator").Unprotect Password:="secret"
Sheets("Components Data").Range("F1:F" & lr).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range("DW1"), Unique:=True
With ThisWorkbook.Worksheets("Calculator")
.Range(.Range("DW1"), .Range("DW1").End(xlDown)).Copy
.Range("DX1").PasteSpecial xlPasteValues, Transpose:=True
.Columns("DW").EntireColumn.Delete
End With
Sheets("Calculator").Protect Password:="secret", DrawingObjects:=False
End Sub
Here's my Component sheet
And below is my Calculator sheet. as you can see, the code to transpose the distinct Components works fine. i just do not know how to get the value of Row 1 starting from DX so i can store it in a variable which i will use in counting the number of times that component appeared in a week . I'm thinking it should go like this
Component = wsCalculator.Cells(i, "D").Value
But this code only works if i want to get the Values of all cells in Column D, not the values of the cells next to D1
and here's the code i currently have
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
Dim ComponentCount As Integer
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("F2:F" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'//Looping through all filled rows in the Components Data sheet
For i = 2 To wsCalculator.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Component from cell in column "DW"
'Component = wsCalculator.Cells(i, "DW").Value
'//Count the # of calls that got hit in the corresponding Component
If wsCalculator.Cells(i, "DW").Value <> "" Then
ComponentCount = Application.WorksheetFunction.CountIf( _
ComponentRange, component)
wsCalculator.Cells(i, "DX").Value = ComponentCount
End If
Next
End Sub
I'll take a crack at this. I'm not 100% sure what you are doing, but I'm going to assume you will have soon calculations in cells D2, down, and to the right. Is that correct? Try this small code sample to copy from D2 (down and right) on the "Components Data" sheet, and transpose to your "Calculator" sheet.
Sub TransposeThis()
Set Rng = Sheets("Components Data").Range("D2:D7") 'Input range of all fruits
Set Rng_output = Sheets("Calculator").Range("B2") 'Output range
For i = 1 To Rng.Cells.Count
Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed
If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
For j = 1 To rng_values.Cells.Count
Rng_output.Value = Rng.Cells(i).Value
Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
Set Rng_output = Rng_output.Offset(1, 0) 'Shifting the output row so that next value can be printed
Next j
End If
Next i
End Sub
Before:
After:
If I got something wrong, post your feedback, and I'll adjust the code to suit your needs.
The code below is your own code, in part, which I commented, and of my own making for those parts where you seemed to have lost your way.
Public Sub CountComponent()
' Locations:-
Dim WsComp As Worksheet
Dim WsCalc As Worksheet
Dim CompRng As Range ' column A
Dim CalcRng As Range ' Calculator!D1:D?)
Dim Rt As Long ' Target row (in WsCalc)
' Helpers:-
Dim Cell As Range
Dim R As Long
Set WsComp = Sheets("Components Data")
Set WsCalc = Sheets("Calculator")
WsCalc.Unprotect Password:="secret"
Application.ScreenUpdating = False
'//Get the index of the last filled row based on column A
With WsComp
' observe the leading period in ".Rows.Count"
'LastComponentRowIndex = .Cells(.Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
'Set CompRng = .Range("A2:A" & LastComponentRowIndex)
' avoids the need for decalring LastComponentRowIndex
Set CompRng = .Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))
End With
With WsCalc
' set a range of all criteria to look up
Set CalcRng = .Range(.Cells(1, "D"), _
.Cells(1, .Columns.Count).End(xlToLeft))
'//Get the index of the last non-empty row in column B
' loop through all rows in WsCalc
For R = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
If Val(.Cells(R, "B").Value) Then ' presumed to be a week number
'//Loop through all audit criteria
For Each Cell In CalcRng
With .Cells(R, Cell.Column)
.Value = WorksheetFunction.CountIfs( _
CompRng, Cell.Value, _
CompRng.Offset(0, 1), WsCalc.Cells(R, "B").Value)
.NumberFormat = "0;-0;;" ' suppress display of zero
End With
Next Cell
End If
.Cells(R, "C").Value = WorksheetFunction.Sum(CalcRng.Offset(R - 1))
Next R
End With
Application.ScreenUpdating = True
End Sub
Frankly, I couldn't understand all of your intentions. I presumed that column B in your Calculations sheet would contain a week number and that this week number would also be found in the Components Data (in column B). If so, you would be counting the occurrences of each component by week, and that is what I programmed.
I think it doesn't matter if I got that part wrong. Your main question was how to look up each of the Components in Calculations!D1:??. That method is very well demonstrated in my above answer and I feel confident you will be able to transplant the useful bits to your own project. Good luck!
I suggest taking a look at VBA dictionaries. In this case, you could store each component as a key and for the value you can accumulate the number of occurrences of the component for a given week.
I don't have a VBA editor available on my computer at the moment to test this, but it would likely look something along the lines of what I've got below. Also, I'll admit that I may not have fully understood the layout of your sheets, but the general principle here will definitely apply.
For a pretty full overview of dictionaries in VBA, here's a good resource that'd I'd recommend: https://excelmacromastery.com/vba-dictionary/
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("A2:A" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'// Declare a new dictionary
dim componentDict as New Scripting.Dictionary
'// First loop through the Calculator sheet to get each component
'// and set initial value to zero
dim i as Long, lastCalcColumn as Long
lastCalcColumn = wsCalculator.Cells(1, Columns.count).end(xlToLeft).Column
for i = 4 to lastCalcColumn
'// Adding each item to dictionary, a couple of ways to write this,
'// but this is probably the easiest
componentDict(wsCalculator.Cells(i, 1).Value) = 0
next i
'//Looping through all filled rows in the Components Data sheet
'// I changed this to loop through each row in your component sheet
'// So that we can accumulate the total occurences
dim current_key as String
For i = 2 To LastComponentRowIndex
If wsComponentData.Range("G" & i).Value <> "" Then
'// assuming component names are in the "G" column
'// change this as needed
current_key = wsComponentData.Range("G" & i).Value
componentDict(current_key) = componentDict(current_key) + 1
end if
Next i
'// now back to the Calculator sheet to enter the values
for i = 4 to lastCalcColumn
current_key = wsCalculator.Cells(i, 1).Value
wsCalculator.Cells(i, 2).Value = componentDict(current_key)
next i
End Sub
I am looking to create an excel workbook, where I will have a button(s) - when clicked on it, it should write the date, number of times it clicked on that day.
I am able to write the date, based on a macro, however I am struggling in two scenarios. Presently I am only able to update the date in the same cell.
1. I would like to append it, in the row below, rather erase the same cell and update it.
2. The number of times the user clicked on the day (should be on the column next to it), should be updated dynamically, and should match the date column next to it.
Any thoughts on the logic, would be helpful.
This is the result, I am looking to get, this is two columns.
7/29/19 5
7/30/19 9
7/31/19 12
So to start, we're going to have to have our program figure out what cell contains the most recent date that is in our list. Once we get that cell, we can compare it's value to the current date in order to determine if we need to add +1 to that day or start a new row.
I have provided an example subroutine below and you will have to replace the contents inside of the square brackets to match your sheet that you're working in.
Sub buttonPressed()
Dim lastRow, dateColumn As Long
Dim lastDate As Date
Dim clickCtr As Long
With Sheets([sheetName])
'Set the column containing dates.
dateColumn = [column number where dates are stored]
'Get the last row containing a date and save it into lastRow
lastRow = .Cells(.Rows.Count, dateColumn).End(xlUp).row
'Convert value of lastRow into a date
lastDate = DateValue(.Cells(lastRow, dateColumn).Value)
'Compare last date to current date
If (lastDate = Date) Then
'Get the current button press count and add 1 to it
clickCtr = .Cells(lastRow, dateColumn + 1).Value + 1
'Replace contents of cell with new click amount
.Cells(lastRow, dateColumn + 1).Value = clickCtr
Else
'Add the new date to the next row
.Cells(lastRow + 1, dateColumn).Value = Date
'Start the counter next to the new date
.Cells(lastRow + 1, dateColumn + 1).Value = 1
End If
End With
End Sub
If I understand what you are asking here's my attempt at it.
Sub stuff()
Dim dateCol As Range
Dim countCol As Range
Set dateCol = ThisWorkbook.Worksheets("Sheet2").Range("A:A") ' Change to proper sheet
Set countCol = ThisWorkbook.Worksheets("Sheet2").Range("B:B") ' Change to proper sheet
Dim foundDate As Range
Dim searchDate As String
searchDate = Format(Now(), "m/dd/yyyy")
Set foundDate = dateCol.Find(what:=searchDate, lookat:=xlWhole)
If Not foundDate Is Nothing Then
foundDate.Offset(0, 1).Value = foundDate.Offset(0, 1).Value + 1
Else
Dim newEntry As Range
If dateCol.Cells(1, 1).Value <> "" Then
Set newEntry = dateCol.Cells(dateCol.Cells.Count, 1).End(xlUp).Offset(1, 0)
Else
Set newEntry = dateCol.Cells(1, 1)
End If
newEntry.Value = searchDate
newEntry.Offset(0, 1).Value = 1
End If
End Sub
With zero luck finding a solution on the web I was wondering if anyone here can help me. Below is an example of my calendar.
Above is my calendar with Month, weeknumber and days at the very top. At the very left there are names. I am trying to get the names of the persons who have F in cell of current day (if April the 13th was today). The days has DD.MM.YYYY Format.
Explained in details:
Im looking for a code that finds todays date in row 3. when that date is found find all cells in column W wich contains "F". Then i want the name of the person in that row.
And finally a bad illustrated image of what im thinking.
The output should look something like this. All the names should not be listed in one cell.
Hope for some help! -J
If your Row 3 has dates like DD/MM/YYYY but you changed the format to Custom and only included DD, then the following will work:
Sub foo()
Dim LastRow As Long
Dim LastCol As Long
Dim NextEmptyRow As Long
Dim SearchDate As String
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "D").End(xlUp).Row
'SearchDate = Format(Now(), "dd/mm/yyyy")
'change the line below with the one above to search for today's date
SearchDate = "13/04/2017" 'find "today's" date
LastCol = Sheet1.Cells(3, Sheet1.Columns.Count).End(xlToLeft).Column 'get the last Column
Sheet2.Cells(1, 1).Value = "Output"
For i = 1 To LastCol 'loop through all columns
ValueToFind = Format(Sheet1.Cells(3, i).Value, "dd/mm/yyyy") 'format the values on row 3 to full date as dd/mm/yyy
If ValueToFind = SearchDate Then 'if date on Row 3 matches SearchDate then
For x = 4 To LastRow 'loop through rows
If Sheet1.Cells(x, i).Value = "F" Then 'if F exists on that column
NextEmptyRow = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'check the next free row on Sheet 2 column A
Sheet2.Cells(NextEmptyRow, 1).Value = Sheet1.Cells(x, 4).Value 'copy the name to Sheet2 on the next available Row
End If
Next x
End If
Next i
End Sub
Date | data | data | data
12/29| G | F | G
12/30| G | |
I have a spreadsheet like above. I want to find the row that is the current date, then reference the row that is the current date in a Range type. Then cycle through the data in that row.
I can find the current date, and get the address of the cell that is the current date:
dateRange = "A1:" & regionSheet.Range("A1").End(xlDown).Address
For Each cell In regionSheet.Range(dateRange)
If cell.Value = Date Then
row = cell.Address
End If
Next cell
That returns $A$2. I need to somehow turn this into a Range type. I tried using the cell.Address like below:
row = cell.Address & ":" & regionSheet.Range(row).End(xlRight).Address
but that errors out.
Maybe I'm going about this the wrong way? Any ideas?
range(cell, cell.End(xlToRight)).Address
OR
range(cell.Address, range(cell.Address).End(xlToRight)).Address
EDIT: If you want it to have it in Range type, you could use
range(cell, cell.End(xlToRight))
Be warned that the End() function can return incorrect results if there are gaps in the data. For example, if you had data in the second and fourth columns, End will not give you the result you want.
You could try something like this (assumes your data starts in row 1 and column 1):
Sub RowOfCurrentDate()
Dim lngCurrDateRow As Long
Dim lngNumCols As Long
Dim rngDates As Range
Dim rngToday As Range
Dim c As Range
'Get current region and count the number of columns
Set rngDates = Range("A1").CurrentRegion
lngNumCols = rngDates.Columns.Count
'Resize the range down to one column
Set rngDates = rngDates.Resize(rngDates.Rows.Count, 1)
'Find today's date in the range
lngCurrDateRow = Application.WorksheetFunction.Match(CLng(Date), rngDates, 0)
'Set the range to search through for today
Set rngToday = Range(Cells(lngCurrDateRow, 1), Cells(lngCurrDateRow, lngNumCols))
'then loop through all cells in that range
For Each c In rngToday
'if cell is not empty
If Len(c) > 0 Then
'do something
End If
Next c
End Sub