I have an excel sheet that has three columns: employee number employee name availability What I am trying to do is when the availability value changes from a number to nothing the employee number and the employee name associated with that row gets a strikethrough. Also when an availability number is added the strikethrough disappears. I have written some code below but I have no idea if I am going in the right direction.
Sub change(ByVal Target As Range)
Dim ws As Worksheet
Dim watchrange As Range
dim intersectrange as range
Set ws = Worksheets("Workbench Report")
endrow = ws.Cells(ws.Rows.count, "E").End(xlUp).Row
Set watchrange = Range("E2:E" & endrow)
Set intersectrange = Intersect(Target, watchrange)
If intersectrange = "" Then
ws.Range("B" & rng.Row).Resize(1, 2).Font.Strikethrough = True
Else
'do nothing
End If
End Sub
Could someone help me?
Thank you in advance
With data like:
This worksheet event macro:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim watchrange As Range, r As Range, rw As Long
Dim intersectrange As Range, endrow As Long
endrow = Cells(Rows.Count, "A").End(xlUp).Row
Set watchrange = Range("C2:C" & endrow)
Set intersectrange = Intersect(Target, watchrange)
If intersectrange Is Nothing Then Exit Sub
For Each r In intersectrange
rw = r.Row
If r.Value = "" Then
Range("A" & rw & ":B" & rw).Font.Strikethrough = True
Else
Range("A" & rw & ":B" & rw).Font.Strikethrough = False
End If
Next r
End Sub
will meet your needs. You need to adjust the columns to match your data schema.
Because it is worksheet code, it is very easy to install and automatic to use:
right-click the tab name near the bottom of the Excel window
select View Code - this brings up a VBE window
paste the stuff in and close the VBE window
If you have any concerns, first try it on a trial worksheet.
If you save the workbook, the macro will be saved with it.
If you are using a version of Excel later then 2003, you must save
the file as .xlsm rather than .xlsx
To remove the macro:
bring up the VBE windows as above
clear the code out
close the VBE window
To learn more about Event Macros (worksheet code), see:
http://www.mvps.org/dmcritchie/excel/event.htm
EDIT#1:
This code is triggered by changes to column C and reside in the worksheet code area for that sheet.
If your button code changes those column C values, then this event code would work with it.
Related
The two modules below always run in a loop.
I want the second module for verification that a record was created after the first module runs, since all the user sees is the question, but not the result.
First module detects when new row is added to a table and asks if you want to export data to another worksheet:
Sub NewDatabaseEntry()
Dim sh As Worksheet
Dim rspn As VbMsgBoxResult
rspn = MsgBox("Do you want to create a project? If you did not add a new row, click No", vbYesNo)
If rspn = vbNo Then Exit Sub
Range("MasterTemplate").Copy
Sheets("Database").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteFormulas
FindProjectName 'A macro that literally finds the name of the project...
'FindRow
End Sub
This module then looks at the row number on the destination worksheet and then copies that row number value to a predefined range.
Sub FindRow()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("Projects").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundRng As Range
For Each rng In Sheets("Projects").Range("B2:B" & LastRow)
Set foundRng = Sheets("Database").Range("C:C").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If Not foundRng Is Nothing Then
rng.Offset(0, -1) = foundRng.Row
End If
Next rng
Application.ScreenUpdating = True
End Sub
The only way FindRow works is when I place it in the ThisWorkbook~ Excel Object.
If I place it anywhere else, it gets into a loop with the NewDatabaseEntry module where it keeps asking you if youwant to create a new project.`
I would've liked for the user to know that the entry was created without having to close out of the workbook and then reopening it, just to verify what row number their record was placed on.
Is there something I am missing?
Since you mention that this gets stuck in an infinite loop to ask if they want to create a new project, I believe that the reason is because you have a Worksheet_Change event (or similar) that fires off when you add a value to the Projects worksheet.
The problem comes in when you have your FindProject manipulating data on the same worksheet that your Worksheet_Change event is looking for.
So what I believe you should do is turn off events until FindProject is done (by the way, I would recommend changing FindProject to something else because it does more than just "find a project").
Sub FindRow()
Application.ScreenUpdating = False
Application.EnableEvents = False ' ADDED THIS
Dim LastRow As Long
LastRow = Sheets("Projects").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundRng As Range
For Each rng In Sheets("Projects").Range("B2:B" & LastRow)
Set foundRng = Sheets("Database").Range("C:C").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If Not foundRng Is Nothing Then
rng.Offset(0, -1) = foundRng.Row
End If
Next rng
Application.EnableEvents = True ' ADDED THIS
Application.ScreenUpdating = True
End Sub
I have a data connection to an internal website that grabs a full webpage and imports it to the "DC" sheet. From there it's moved to "staging" via an advanced filter macro using the below code. The N1100 is not the last row with text, it was a arbitrary number a fair distance past the end of my data.
Private Sub Worksheet_Change(ByVal Target As Range)
Call Password_Unprotect
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("DC")
Dim lrng As Range
Set lrng = ThisWorkbook.Sheets("DC").Range("A158:N1100")
Dim crng As Range
Set crng = ThisWorkbook.Sheets("DC").Range("A158:N1100")
Dim copyto As Range
Set copyto = ThisWorkbook.Sheets("Staging").Range("A1:H1")
lrng.AdvancedFilter xlFilterCopy, crng, copyto, Unique:=False
'Call password_protect
End Sub
My problem is that whenever the the webpage I use for my data connection changes it breaks my advanced filter since the row my criteria starts on shifts. I'm looking to either make the advanced filter smart enough to find the line it needs to start on or delete every line above it then move the data over to the "staging" sheet. A point of note, the cell containing "Division" is unique on the sheet. The highlighted line is the start of the advanced filter.
I've uploaded a snit-it of my worksheet.
The below code should get you what you looking for. Just need to run through Column A to look for the DEVICE text and then use that as start and then do a .End(xlUp) on Column A for the last Row.
Another note, always remember to use Option Explicit on on all your sheet to ensure you always declaring your variables.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Call Password_Unprotect
Dim DCSheet As Worksheet
Dim lrng As Range
Dim crng As Range
Dim copyto As Range
Dim StartRow As Long
Dim ColACell As Range
Dim LastRow As Long
Set DCSheet = ThisWorkbook.Sheets("DC")
LastRow = DCSheet.Cells(DCSheet.Rows.Count, "A").End(xlUp).Row
'Stopping at 300 will just save time if the text is not found
'if it is possible that the start row could be further down then increase the number
For Each ColACell In DCSheet.Range("A1:A300").Cells
If ColACell.Text = "DEVICE" Then
'Can have cross check for the IP text in Column B
If ColACell.Offset(0, 1).Text = "IP" Then StartRow = ColACell.Row
End If
Next ColACell
Set lrng = DCSheet.Range("A" & StartRow & ":N" & LastRow)
Set crng = DCSheet.Range("A" & StartRow & ":N" & LastRow)
Set copyto = ThisWorkbook.Sheets("Staging").Range("A1:H1")
lrng.AdvancedFilter xlFilterCopy, crng, copyto, Unique:=False
'Call password_protect
End Sub
I have the following workbook called master:
Column I Column K
1234
1222
1111
I also have a workbook called slave:
Column J Column R
1234 Ambient
1222 Ambient
1111 Chiller
When the user enters/pastes the number in column I on my master workbook, i want to check if the same number exists in my slave workbook in column J.
If it does, i want to copy the corresponding prodcut groups from column R over to my master workbook in column K.
The other problem is my slave workbook changes name from time to time, but will always contain the word 'Depot memo' like so:
Food Depot Memo
Drinks Depot Memo 01-19
etc.
I am trying to reference my slave workbook by checking if the file name contains 'depot memo'.
For some reason this is not working. Please can someone show me where i am going wrong?
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
Dim Dic As Object, key As Variant, oCell As Range, i As Long
Dim w1 As Worksheet, w2 As Worksheet
If Not Intersect(Target, Range("I:I")) Is Nothing Then ' <-- run this code only if a value in cell C5 has change
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
If Not Dic.exists(Target.Value) Then
Dic.Add Target.Value, Target.Offset(1, 0).Value
End If
Dim wbInd As Integer
Dim wb2 As Workbook
For wbInd = 1 To Workbooks.Count ' <-- loop through all open workbooks
If Workbooks(wbInd).Name Like "Depot Memo*" Then '<-- check if workbook name contains "volumes"
Set wb2 = Workbooks(wbInd)
Exit For
End If
Next wbInd
On Error GoTo message
Set w2 = wb2.Sheets(1)
With w2
i = .Cells(.Rows.Count, "J").End(xlUp).Row
End With
For Each oCell In w2.Range("J6:J" & i)
For Each key In Dic
If oCell.Value = key Then
Target.Offset(0, 2).Value = oCell.Offset(0, 8) '<-- put the the value in column F (offset 1 column) to cell C6 (one row offset)
End If
Next
Next
End If
Application.EnableEvents = True
Exit Sub
message:
Exit Sub
End Sub
EDIT:
With the suggested code from #user3598756 i encounter this problem:
If the user copy and pastes these values, rather than typing them, the correct supplier number does not correspond with the item number in column I.
This is obviously not correct, since it should have a different supplier number for each different item number.
edited to handle multiple changed cells
one thing that doesn't work as you'd expect is :
Like "Depot Memo*
that would not detect neither "Food Depot Memo" nor "Drinks Depot Memo 01-19"
while you have to use
Like "*Depot Memo*"
Furthermore:
there's no need for any Dictionary object
you don't need to iterate with For Each oCell In w2.Range("J6:J" & i)
so I'd go with the following refactoring of your code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oCell As Range, targetCell As Range
Dim ws2 As Worksheet
If Not Intersect(Target, Range("I:I")) Is Nothing Then ' <-- run this code only if a value in column I has changed
If Not GetWb("Depot Memo", ws2) Then Exit Sub
With ws2
For Each targetCell In Target
Set oCell = .Range("J1", .Cells(.Rows.count, "J").End(xlUp)).Find(what:=targetCell.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not oCell Is Nothing Then
Application.EnableEvents = False
targetCell.Offset(0, 2).Value = oCell.Offset(0, 8)
Application.EnableEvents = True
End If
Next
End With
End If
End Sub
Function GetWb(wbNameLike As String, ws As Worksheet) As Boolean
Dim wb As Workbook
For Each wb In Workbooks
If wb.name Like "*" & wbNameLike & "*" Then '<-- check if workbook name contains "Depot Memo"
Set ws = wb.Worksheets(1)
Exit For
End If
Next
GetWb = Not ws Is Nothing
End Function
The wildcard in "Depot Memo*" name check should appear at the beginning AND the end of the text. This would detect if a workbook name contains any text before and/or after "Depot Memo".
If Workbooks(wbInd).Name Like "*Depot Memo*" Then
Data layout: A3 onwards to A(no specific last row) is referred to as under Name Manager as =PeriodPrev.
=PeriodPrev is a label that I have used to mark the data. =PeriodCurr label starts after the last populated row for PeriodPrev.
The remaining data for PeriodPrev and PeriodCurr lay under column E to W.
Code: How to I create a clear contents of data in Columns A and E to W for data belonging to =PeriodPrev in Column A?
I've tried the following code but it does not completely serves the purpose above. "If c.Value = "PeriodPrev" Then" returns error 13. "If c.Value = Range("PeriodPrev") Then" return error 1004.
Sub BYe()
'The following code is attached to the "Clear" button which deletes Previous Period data
Dim c As Range
Dim LastRow As Long
Dim ws As Worksheet
ws = ThisWorkbook.Worksheets("Sheet1")
LastRow = Range("A" & Rows.count).End(xlUp).Row
For Each c In Range("A3:A" & LastRow)
If c.Value = "PeriodPrev" Then
' If c.Value = Range("PeriodPrev") Then
c.EntireRow.ClearContents
End If
Next c
End Sub
Use Intersect
If Not Application.Intersect(c, Range(yourLabel)) Is Nothing Then
Let me know if it doesn't work
There were a few thing wrong with that code. I've tried to address some of the problems with comments
Sub BYe()
'The following code is attached to the "Clear" button which deletes Previous Period data
Dim c As Range, lastRow As Long, ws As Worksheet
'you need to SET a range or worksheet object
Set ws = ThisWorkbook.Worksheets("Sheet1")
'you've Set ws, might as well use it
With ws
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For Each c In .Range("A3:A" & lastRow)
'the Intersect determines if c is within PeriodPrev
If Not Intersect(c, .Range("PeriodPrev")) Is Nothing Then
'this clears columns A and E:W on the same row as c.
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "E").Resize(1, 19)).ClearContents
End If
Next c
End With
End Sub
The following should perform the same action without the loop.
Sub BYe2()
'The following code is attached to the "Clear" button which deletes Previous Period data
Dim lastRow As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
lastRow = .Range("PeriodPrev").Rows(.Range("PeriodPrev").Rows.Count).Row
.Range("A3:A" & lastRow & ",E3:W" & lastRow).ClearContents
End With
End Sub
Currently, I have columns from A to AB. I want to achieve a result such that if any cell is updated in Columns Y:AB of a row, the cells (Column A and Y:AB of a row) will be copied and pasted into a new sheet called Sheet2 into columns A to E.
My code currently can do the above but when I change all 4 values one by one in Columns Y to AB, 4 rows will be generated reflecting each change that was made. E.g. First row to be copied reflects the change made in Column Y. Second row copied reflects the change made in Column Z. Third row copied reflects the change made in Column AB. And so on.
I just need one row copied onto Sheet 2 that reflects all changes made in Columns Y to AB of a row in Sheet 1. Is there a way to do so?
I am not familiar with VBA and all guidance are much appreciated! Thank you
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("Y:AB")) Is Nothing Then Exit Sub
Range("Y" & Target.Row, "AB" & Target.Row).Copy Sheets("Sheet2").Range("B" & Rows.count).End(xlUp).Offset(1, 0)
Range("A" & Target.Row).Copy Sheets("Sheet2").Range("A" & Rows.count).End(xlUp).Offset(1, 0)
End Sub
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
If Intersect(Target, .Range("Y:AB")) Is Nothing Then GoTo forward
Dim trow As Long, drow As Long, rng As Range
trow = Target.Row
Set rng = sh2.Range("A:A").Find(.Range("A" & trow).Value, sh2.Range("A1"))
If rng Is Nothing Then
drow = sh2.Range("A" & .Rows.Count).End(xlUp).Row + 1
sh2.Range("A" & drow) = .Range("A" & trow)
Else
drow = rng.Row
End If
.Range("Y" & trow, "AB" & trow).Copy sh2.Range("B" & drow)
End With
forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume forward
End Sub
I assumed Column A contains unique identifier.
So above code does what you describe and what you explained in your comment. HTH.