For instance, I have a sheet which contains names of 100+ people. In column H I have their birth dates. What will the code look like if I want to find out which friend's birthday is today? Of course the macro will need to run through that column and see if today's date matches one with in column H. I have very little experience with VBA/Macros. Please and thank you for your help.
This code will put a message on I column if someone' birthday is today as per H column. (Assuming G column has person's name.
Sub BirthdayAlert()
Dim lastRow As Long
Dim ws As Worksheet
Dim varArray As Variant
Dim lb As Long
Dim i As Integer
Set ws = Sheets("Sheet1")
lastRow = ws.Range("H" & Rows.Count).End(xlUp).Row
varArray = Application.Transpose(ws.Range("H2:H" & lastRow).Value)
lb = LBound(varArray)
For i = LBound(varArray) To UBound(varArray)
If IsDate(varArray(i)) Then
If CDate(varArray(i)) = Date Then
varArray(i) = "Today is Your Birthday " & Range("G2").Offset(i).Value
Else
varArray(i) = ""
End If
End If
Next i
If UBound(varArray) > 0 Then
ws.Range("I2:I" & lastRow).Value = Application.Transpose(varArray)
End If
End Sub
Here's something simple for it:
Sub birthdayThing()
Dim rng As Range
For Each rng In Range("H2:H100")
If CDate(rng) = Date Then rng.Offset(0, 1).Value = "Birthday"
Next rng
End Sub
Related
I have trouble running this script to obtain Summary information for a specific month. I am explaining below the details of my workbook.
Tab 1 called "Schedule"
Tab 2 called "Results"
Tab 3 called "Sheet3"
I would like to obtain info from column C (Summary) in tab1 for the month of July. I am entering the month in tab2 and would like to run the macro and obtain all the results pertaining to the month of July.
Sub schedule()
Dim sch As Workbook
Dim schTot As Worksheet
Dim schRes As Worksheet
Dim i As Long
Dim j As Long
Let sch = Thisworkbook
Let schRes = sch.Worksheets("Results")
Let schTot = sch.Worksheets("Schedule")
For i = 1 To schTot.Range("A1").End(xlDown)
For j = 3 To schRes.Range("B3").End(xlDown)
If schTot.Cells(i, 1).Value = schRes.Cells(1, 2).Value Then
If schRes.Cells(j, 1).Value = "" Then
schTot.Rows(i).Copy
schRes.Cells(j, 1).Paste
Application.CutCopyMode = False
'Exit For
End If
End If
Next j
Next i
End Sub
Try this:
Option Explicit
Sub schedule()
Dim sch As Workbook
Dim schTot As Worksheet
Dim schRes As Worksheet
Dim i As Long
Dim j As Long
Dim strMonth As String
With ThisWorkbook
Set schRes = .Worksheets("Results")
Set schTot = .Worksheets("Schedule")
End With
schRes.Range("A3:C" & schRes.Cells(3, 1).End(xlDown).Row).ClearContents
strMonth = schRes.Cells(1, 2).Value
i = 2
j = 3
With schTot
Do Until .Cells(i, 1).Value = ""
If .Cells(i, 1).Value = strMonth Then
schRes.Range("A" & j & ":C" & j).Value = .Range("A" & i & ":C" & i).Value
j = j + 1
End If
i = i + 1
Loop
End With
End Sub
For your code, you just need to change following things to get it run:
-use "Set" instead of "Let"
Set sch = Thisworkbook
Set schRes = sch.Worksheets("Results")
Set schTot = sch.Worksheets("Schedule")
-return row's number in for loop condition
For i = 1 To schTot.Range("A1").End(xlDown).Row
For j = 3 To schRes.Range("B3").End(xlDown).Row
Then your code will be ok to run, but if your B3 cell in Results worksheet don't have value or following cells(i.e. B4,B5,B6...) doesn't have vale, your code will run infinitely and crush eventually.
Also, you copy a entire row in loop every single time which contain unnecessary cells. This will horribly slow down your code.
To speed up the code, I recommend to use auto filter to solve the problem:
Sub sechedule()
Dim sch As Workbook: Set sch = ThisWorkbook
Dim schTot As Worksheet: Set scTot = sch.Worksheets("Schedule")
Dim schRes As Worksheet: Set schRes = sch.Worksheets("Results")
Dim month As String
month = Range("B1").Value 'The month you inputted in Results worksheet
'I suppose you want to paste the result to Results worksheet starting from Cell A3, so the contents will be cleared first each time if somethings are in the result area:
If Range("A3").Value = "" Then Range("A3:C" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
With schTot
.Activate
.Range("A:C").AutoFilter Field:=1, Criterial:=month 'Choose data for specific month with auto filter
.Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=schRes.Range("A3") '<--You can change the paste destination here
.ShowAllData
.Range("A:C").AutoFilter 'Cancel auto filter
End With
schRes.Activate
End Sub
I made a calendar sheet in Excel with all 366 days of the year listed in column A
how can I write an Auto_open macro which automatically selects and activates the cell holding the current date?
Give this a try:
Private Sub Workbook_Open()
Dim cell As Range
Sheets("Sheet1").Activate
Set cell = Range("A:A").Find(What:=Date, After:=Range("A1"))
cell.Select
End Sub
I'd write it as:
Private Sub Workbook_Open()
Dim CellToCheck As Range
For Each CellToCheck In Sheet1.Range("A1:A366") 'To make dynamic, you could make use of finding lastrow and searching until that row.
If CellToCheck.Value = Date Then
CellToCheck.Select
Exit For
End If
Next CellToCheck
End Sub
Outcome:
For this code to work you need to enter it into the ThisWorkbook code module and choose Workbook and Open from the appropriate drop-down menus, like so:
Private Sub Workbook_Open()
Dim lastrow As Long
Dim lastcol As Long
Dim t As Date
Dim u As Date
Dim v As Long
Dim w As Long
Dim notolet As String
Sheets("all").Activate ' your sheet name here
With ActiveSheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
End With
t = Now()
u = Format(t, "dd/mm/yyyy")
notolet = Split(Cells(1, lastcol).Address, "$")(1)
For v = lastrow To 2 Step -1
Select Case Cells(v, 1).Value
Case u
Range("A" & v & ":" & notolet & v).Interior.ColorIndex = 6
Exit For
End Select
Next
w = v
End Sub
In my problem:
First, I need to find "Unit Name" in Column B.
If it found "Unit Name" it should look for "First Name:" in Column D and copy 5 cell right. ("Obama" in I10)
Paste the name "Obama" to Unit Name sheet. (Paste "Obama" to Sheet "1" A1)
I am new in coding therefore i don't know too much about it. I tried with some codes but it is not efficient.
Here is an image to show my problem.
Sub Test()
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim z As Integer
For i = 1000 To 1 Step -1
If Range("B" & i).Value = "Unit Name" Then
m = 2
m = i + 1
n = i - 18
If Range("D" & n).Value = "First Name:" Then
m = Range("B" & m).Value + 1
Range("H" & n).Copy
Sheets(m).Range("B7").PasteSpecial xlPasteValues
End If
End If
Next i
End Sub
You don't need all those integer variables, you can use a few Range variables instead:
Sub find_name()
Dim mainWS As Worksheet, altWS As Worksheet
Dim unitCel As Range, fNameCell As Range
Set mainWS = Worksheets("Sheet2") 'CHANGE AS NEEDED
Set altWS = Worksheets("Sheet1")
With mainWS
Set unitCel = .Range("B:B").Find(What:="Unit Name")
If Not unitCel Is Nothing Then
Set fNameCell = .Range("D:D").Find(What:="First Name:").Offset(0, 5)
altWS.Range("A1").Value = fNameCell.Value
End If
End With
End Sub
May need to tweak this, depending on where your data is. I am assuming "Obama" could be any text, that is three columns right of column D, where "First Name:" is found.
Sub Shift_Over5()
Dim i As Long
'Sheet name should be a string
Dim SheetName As String
Dim FirstName As Range
Dim UnitName As Range
'Dim l As Byte --> I changed it to lUnitSheetLastrow, because we need to copy the data from sheet1 to sheet 1,2...
' then you need to check the last row of unit sheet and write data to the last row + 1.
Dim lUnitSheetLastrow As Long
Dim FirstMatch As Variant
Dim Start
Start = VBA.Timer
For i = 1 To 40000 Step 1
'For clear code and easy to follow, you need to mention the sheet you want to interact
'Here i use 'Activesheet', i assume that the current sheet is sheet1
If ActiveSheet.Range("A" & i).Value = "Unit Name" Then
' i think we dont need this code line, because we identified the cell in column B has value is "Unit Name"
'Set UnitName = Range("A:A").Find(what:="Unit Name")
' Here you dont need to use Offset
'SheetName = UnitName.Offset(1, 0).Value
SheetName = ActiveSheet.Range("A" & (i + 1)).Value
' Find "First Name" in 20 rows in column E.
' What happen if i<20, the nextline will show the error, because the minimum row is 1
If i < 40 Then
Set FirstName = ActiveSheet.Range("D1" & ":D" & i).Find(what:="First Name:")
Else
Set FirstName = ActiveSheet.Range("D" & i & ":D" & (i + 40)).Find(what:="First Name")
End If
' make sure the SheetName is not empty and Unit sheet is existing in you workbook then copy the first name to unit sheet
If SheetName <> "" And CheckWorkSheetAvailable(SheetName) Then
' Check the first name is not nothing
If Not FirstName Is Nothing Then
'Check if the cell B7 in unit sheet empty or not
If Worksheets(SheetName).Range("H7").Value = "" Then
'if empty, write to B7
Worksheets(SheetName).Range("H7").Value = FirstName.Offset(1, 0).Value
Else
'else, Find the lastrow in column D of unit sheet
lUnitSheetLastrow = Worksheets(SheetName).Cells(Worksheets(SheetName).Rows.Count, 1).End(xlUp).Row
'Write data to lastrow +1
Worksheets(SheetName).Range("A" & (lUnitSheetLastrow + 1)).Value = FirstName.Offset(, 1).Value
End If
End If
End If
'You forgot to put end if here
End If
Next i
Debug.Print Round(Timer - Start, 3)
End Sub
Function CheckWorkSheetAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = SheetName Then
CheckWorkSheetAvailable = True
Exit For
End If
Next
End Function
thank you everyone I found the answer.
I need to use VBA code to populate a list of filtered blank cells. I decided to make a picture with small example to explain it easier. Column D should be populated with names from col A repeating until each ID has a name.
I have absolutely no idea how to loop it to make it work - it's mind boggling! I have been searching the web for hours so I am now asking for help. Please note that column C and D are filtered with criteria blanks for column D.
Here is working code to populate blank cells of a filtered list with the same 3 names alternating.
Sub Macro1()
Dim last As Long
Dim counter As Integer
Dim nameRange As Range
Dim cell As Range
last = Range("A2").End(xlDown).Row
Set nameRange = Range("D2:D" & last).SpecialCells(xlCellTypeVisible)
counter = 1
For Each cell In nameRange
If counter = 1 Then
cell.Value = "Carrie"
counter = counter + 1
ElseIf counter = 2 Then
cell.Value = "Lisa"
counter = counter + 1
Else
cell.Value = "Bob"
counter = 1
End If
Next
End Sub
thanks for everyone's input - Hopefully, this will help someone else in the future.
This will do it without the need of filtering the data.
Sub foo()
Dim ws As Worksheet
Dim lastrowa As Long
Dim lastrowd As Long
Dim counta As Long
Dim rng As Range
counta = 2 'First row of name list in column A
Set ws = Sheets("Sheet1")
With ws
lastrowa = .Range("A" & .Rows.Count).End(xlUp).Row
lastrowd = .Range("D" & .Rows.Count).End(xlUp).Row
For Each rng In .Range(.Cells(2, 5), .Cells(lastrowd, 5))
If rng.Value = "" Then
rng.Value = .Cells(counta, 1).Value
If counta = lastrowa Then
counta = 2
Else
counta = counta + 1
End If
End If
Next rng
End With
End Sub
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range("D2:D11")
If you don't know where column C ends that is easy enough to work out. Something like
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
If you don't know how far the data extends in column A:
Dim last As Integer
last = Range("A2").End(xlDown).Row
Range("D2:D" & last).Value = Range("A2:A" & last).Value
Range("D2:D" & last).AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
My example doesn't work perfectly, or even well... Its late :)
Create a named range that encapsulates all your "names" (called namesRange in my example).
In your "assigned" column put the following formula:
=INDEX(namesList,ROW()-((INT(ROW()/ROWS(namesList))*ROWS(namesList))),1)
Update...
Thought about it, and remembered how to excel a little more.. The following is what I was trying to do in my first example.
=INDEX(namesList,MOD(ROW()-1,ROWS(namesList)-1)+1,1)
I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.