I wonder if anyone can help I am using a macro but I need to adapt it ...
Sub findApp()
lookfor = Selection.Value
Sheets("Home (2)").Activate
Cells.Find(What:=lookfor, After:=ActiveCell,
LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Select
If todays date is >or equal to January but < July search column “D”sheet2
If todays date is >or equal to July but <January search column “J” sheet2
I would really appreciate some help Thanks
This code will search column D for today's date + 6 months if the month is between Jan and June, or column J if month is between July and December and color every match green.
Not 100% sure that is what you are after but please clarify if not.
Sub findApp()
Dim rw As Integer
With Sheet2
If Month(Date) < 7 Then
For rw = 2 To .Range("D1048576").End(xlUp).Row
If .Cells(rw, 4).Value = DateAdd("m", 6, Date) Then
.Cells(rw, 4).Interior.ColorIndex = 4
End If
Next rw
Else
For rw = 2 To .Range("J1048576").End(xlUp).Row
If .Cells(rw, 10).Value = DateAdd("m", 6, Date) Then
.Cells(rw, 10).Interior.ColorIndex = 5
End If
Next rw
End If
End With
End Sub
Related
I am working on a vba code to do the following:
In row 5, 7, 9, 11, 13, 15, 17, 19, and 21 from column D until M. Check the value in these cells (which is a date). If the date is 3 months before the date of today turns the cell yellow. If the date is one month before the date of today turn the cell orange. If the date in the cell is today or has passed turn the cell red.
I have the following only the range needs to be adjusted:
Sub ChangeColor()
Dim rCell As Range
With Sheet1
For Each rCell In .Range("D4")
If rCell.Value <= Date Then
rCell.Interior.Color = vbRed
ElseIf rCell.Value <= Date + 30 Then
rCell.Interior.Color = vbOrange
ElseIf rCell.Value <= Date + 90 Then
rCell.Interior.Color = vbYellow
End If
Next rCell
End With
End Sub
This should do it.
Dim rCell As Range
With Sheet1
For Each rCell In .Range("D5:M21") ' Change the Range
If rCell.Row Mod 2 = 1 Then ' Only odd rows
If rCell.Value <= Date Then
rCell.Interior.Color = vbRed
ElseIf rCell.Value <= Date + 30 Then
rCell.Interior.Color = RGB(255, 150, 0) ' vbOrange isn't a thing
ElseIf rCell.Value <= Date + 90 Then
rCell.Interior.Color = vbYellow
End If
End If
Next rCell
End With
I kindly ask you help me on this issue.
Please look Data below:
Name StartDate EndDate
John 17.07.2016 17.07.2017
John 17.07.2017 17.07.2018
Maria 01.08.2017 01.08.2018
Chris 05.01.2018 05.01.2019
Workers and their working years. I need to add new line for worker when his/her working year finished. For example when the date > 17.07.2018 I need to add new line for John. (date = today formula)
It look like simple but this is a part of my vacation module.
I started to write code like this.
Sub AddWorkingYearLine()
Dim WorVac As Worksheet: Set WorVac = Worksheets("WorkerVacation")
Dim i As Long
Dim LRow As Long
Dim LCol As Long
Dim MyTable As Variant
LRow = Range("A1048576").End(xlUp).Row: LCol = Range("XFD4").End(xlToLeft).Column
MyTable = Range(Cells(4, 1), Cells(LRow, LCol))
For i = 1 To UBound(MyTtable, 1)
If Branches.Range("C" & i) > Range("G1") Then 'Range("G1") = today formula
End If
Next i
End Sub
Thank you all!
Here's my interpretation of your request. If column "C" of the current row occurs before today then it will insert a row, copy the current row into that new row, and then increment the year on those dates.
Sub AddWorkingYearLine()
Dim i As Long
For i = Cells(Rows.count, "A").End(xlUp).row To 4 Step -1
'make sure it's not an "old entry"
If Cells(i, "A").Value2 <> Cells(i + 1, "A").Value2 Then
'if today occurs after "end date" then
If Date > CDate(Cells(i, "C").value) And Len(Cells(i, "C").Value2) > 0 Then
'insert row
Rows(i + 1).Insert Shift:=xlShiftDown
'copy row down
Rows(i + 1).value = Rows(i).value
'update dates
Cells(i + 1, "B").value = Cells(i, "C").value
Cells(i + 1, "C").value = DateAdd("yyyy", 1, CDate(Cells(i, "C").value))
End If
End If
Next i
End Sub
Column B is my data - if there is a date value in column B please return week ending date in column C. Need a VBA code to accomplish this
Column B Column C
11/9/2016 11/11/2016
11/8/2016 11/11/2016
4/4/2017 4/7/2017
(blank) (blank)
3/28/2017 3/31/2017
Below is all I could get, but it's not any good.
Dim FirstDayInWeek, LastDayInWeek As Variant
Dim dtmDate As Date
dtmDate = Range("B2:B")
LastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
MsgBox LastDayInWeek
I replied to your comment on how to find the start date of week from a given date?, but here it is as an answer:
Function ReturnDate(DateRange As Date, Optional DayInWeek = 1) As Date
ReturnDate = DateRange - Weekday(DateRange, vbUseSystem) + DayInWeek
End Function
=ReturnDate(A1) gives Monday
=ReturnDate(A1,2) gives Tuesday
.
=ReturnDate(A1,5) gives Friday < --- This is the one you're after.
=ReturnDate(A1,7) gives Sunday.
A blank cell will give 01/01/1900, but you could add a check for that or format the cell not to show 0.
Perhapse you could take an approach like the one below
Sub ReturnWeekEndDate()
Dim InpRng As Range
Dim i As Long
Set InpRng = ActiveSheet.Range("A2:B5")
For i = 1 To InpRng.Rows.Count
If IsDate(InpRng.Cells(i, 1).Value) And IsDate(InpRng.Cells(i, 2).Value) Then
InpRng.Cells(i, 1).Offset(0, 2) = InpRng.Cells(i, 1).Value - Weekday(InpRng.Cells(i, 1).Value, vbUseSystem) + 7
End If
Next i
End Sub
Give this a try:
Sub INeedADate()
Dim i As Long, N As Long, r As Range, Bigr As Range
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
Set r = Cells(i, "B")
If IsDate(r.Value) Then
addy = r.Address
r.Offset(0, 1).Value = Evaluate(addy & "-WEEKDAY(" & addy & ",3)+IF(WEEKDAY(" & addy & ",3)>4,11,4)")
End If
Next i
End Sub
This is similar to using the worksheet formula:
=B1-WEEKDAY(B1,3)+IF(WEEKDAY(B1,3)>4,11,4)
Or try this...
Sub GetFridayDate()
Dim LastDayInWeek As Date
Dim Rng As Range, Cell As Range
Dim lr As Long
lr = Cells(Rows.Count, 2).End(xlUp).Row
Set Rng = Range("B2:B" & lr)
For Each Cell In Rng
If IsDate(Cell.Value) Then
LastDayInWeek = Cell + 8 - Weekday(Cell, vbFriday)
Cell.Offset(0, 1) = LastDayInWeek
End If
Next Cell
End Sub
You said that this would be part of a process...so, just call the function as I have shown, and you're golden! BOOM!
Sub FindEndOfWeek_Test()
Call FindEndOfWeek(ActiveSheet, 1, 2, 6, 1)
End Sub
Function FindEndOfWeek(Sht As Worksheet, KnownDate_Column As Integer, _
EndOfWeek_Column, EndOfWeek As Integer, _
StartingRow As Long)
' This function takes in a spreadsheet, and and determines the date at the end
' of the week, based on known parameters being passed into the function.
'
Dim a As Long
Dim LastRow As Long
Dim EvalDate As Date
Dim NewDate As Date
' Determine the last row of the column you are working with
LastRow = Sht.Cells(Sht.Rows.Count, KnownDate_Column).End(xlUp).Row
' Loop through your entire spreadsheet to determine the end of the week for all rows
For a = StartingRow To LastRow
If IsDate(Sht.Cells(a, KnownDate_Column).Value) = True Then
NewDate = Sht.Cells(a, KnownDate_Column).Value
EvalDay = Weekday(NewDate)
' Determine the known date day of the week, and add accordingly.
If EvalDay < EndOfWeek Then
Sht.Cells(a, EndOfWeek_Column).Value = NewDate + (EndOfWeek - EvalDay)
ElseIf EvalDay > EndOfWeek Then
Sht.Cells(a, EndOfWeek_Column).Value = NewDate + (7 - EvalDay + EndOfWeek)
Else
Sht.Cells(a, EndOfWeek_Column).Value = NewDate
End If
End If
Next a
End Function
I think no need for vba, you use below formula:
=IF(B2<>"",B2+(7-WEEKDAY(B2,16)),"")
If you really need VBA code for this problem, which I did, you can convert the excel formula into a one-line solution like so:
WeekendingDate = Date + 7 - WorksheetFunction.Weekday(Date + 7 - 6)
Edited)
is this right? I need to do the same thign for column P. Should I do another for loop?
Dim i As Long
For i = 1 To Rows.Count
If Len(Cells(i, "Q").Value) <= 4 Then
Cells(i, 1).NumberFormat = "01/01/yyyy"
Else: Cells(i, "Q").NumberFormat = "MM/DD/YYYY"
End If
Next i
When I import excel file to access, the column that has either the years(19xx) or a full date don't display properly after imported.
The years seem fine but full date is changed to a random number like 39213, etc.
So I tried to format the whole column to text and export to access, the same thing happens.
What should I do?
The original column is in 'general' format
01/01/1962
01/01/1966
01/01/1956
1964
01/01/1943
01/01/1943
01/01/1964
1964
01/01/1972
01/01/1948
01/01/1961
01/01/1953
01/01/1961
01/01/1963
01/01/1963
01/01/1973
1960
01/01/1956
01/01/1940
1958
1958
1955
01/01/1948
01/01/1948
01/01/1970
1959
1964
01/01/1975
1966
This becomes
22647
24108
20455
1964
15707
15707
19
23377
1964
26299
17533
22282
19360
22282
23012
23012
26665
1960
20455
14611
1958
1958
1955
17533
17533
25569
1959
1964
27395
1966
And the latter column is in 'Text' format. I dont know what is wrong
EDITED TO CORRECT FORMAT ISSUE!!
Depending on which approach you want to take (A. Fix in Excel; B. Fix in Access), your solution will vary. To use your code, I modified slightly.
WARNING!! If only a year, my code will destroy content of column 1!! Change to suit your needs.
Sub Convert_Dates()
Dim lLastRow As Long
Dim i As Long
' Find last row
lLastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' Loop until last row
For i = 1 To lLastRow
If Len(Cells(i, "Q").value) <= 4 Then ' IF only a year found
Cells(i, "Q") = "01/01/" & Cells(i, "Q") ' Change date value from yyyy to mm/dd/yyyy
Cells(i, "Q").NumberFormat = "mm/dm/yyyy" ' Set format
Else
Cells(i, "Q").NumberFormat = "mm/dd/yyyy" ' Else just set format.
End If
Next i
End Sub
I think the date format should be "MM/DD/YYYY" across all the rows of "Q". I have modified your code slightly.
Sub test1()
k = Cells(Rows.Count, "Q").End(xlUp).row
Dim i As Long
For i = 1 To k
If Len(Cells(i, "Q").Value) <= 4 Then
Cells(i, "Q").Value = "01/01/" & Cells(i, "Q").Value
Cells(i, "Q").NumberFormat = "MM/DD/YYYY"
Else: Cells(i, "Q").NumberFormat = "MM/DD/YYYY"
End If
Next i
End Sub
After executing all the dates in the column "Q" will be formatted to "MM/DD/YYYY"
And if you want to keep the formatting year with 4 digits in the Q column and format that year separately in column 1, then use the below code
Sub test1()
k = Cells(Rows.Count, "Q").End(xlUp).row
Dim i As Long
For i = 1 To k
If Len(Cells(i, "Q").Value) <= 4 Then
Cells(i, 1).Value = "01/01/" & Cells(i, "Q").Value
Cells(i, 1).NumberFormat = "MM/DD/YYYY"
Else: Cells(i, "Q").NumberFormat = "MM/DD/YYYY"
End If
Next i
End Sub
i'm new to vba and i was trying to make a program to do add multiple items to a key.
Eg:
Table
Name Date Time
XYZ 20 4
ABC 21 5
XYZ 22 6
and then if the names are repeated, then column values to the previous one...like:
Name Date Time Date Time
XYZ 20 4 22 6
ABC 21 5
i've done sorting and adding the sum of duplicate values for a single item value but i'm finding it hard to do this for multivalued item. So plz do help out!!
Thank you!!
Sub t()
Application.DisplayAlerts = False
Dim Tempsheet As Worksheet
Dim c As Range
Set Tempsheet = ThisWorkbook.Sheets.Add
With ThisWorkbook.Sheets("sheet1")
rng = .UsedRange.Address
.UsedRange.Sort key1:=.Range("b1"), order1:=xlAscending, key2:=.Range("c1"), order2:=xlAscending, Header:=xlYes
.UsedRange.Columns(1).Copy
Tempsheet.Range("a1").PasteSpecial (xlPasteValues)
Tempsheet.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
For Each cell In Tempsheet.Range("a1:a" & Tempsheet.Range("a" & Rows.Count).End(xlUp).Row).Cells
i = i + 1
If i <> 1 Then
With .Range(rng)
Set c = .Find(what:=cell.Value, after:=.Range("a1"), LookIn:=xlValues, lookat:=xlWhole)
firstAddress = c.Address
If Not c Is Nothing Then
Do
j = j + 1
If j <> 1 Then
k = k + 1
.Range(c.Offset(0, 1), c.Offset(0, 2)).Copy
.Range(firstAddress).Offset(0, (k * 2) + 1).PasteSpecial (xlPasteValues)
.Range(firstAddress).Offset(-1, (k * 2) + 1) = "Date"
.Range(firstAddress).Offset(-1, (k * 2) + 2) = "Time"
c.EntireRow.ClearContents
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End If
j = 0
Next cell
.UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Tempsheet.Delete
End Sub
You are writing an elaborate program for something that is a basic part of the Excel functionality. It is called Pivot tables.
https://en.wikipedia.org/wiki/Pivot_table
http://www.excel-easy.com/data-analysis/pivot-tables.html