What i have in my files
A Excel Template
A Database to store the template
Both of the files are created by Template Wizard
Purpose of me using the TW is because i have to design a interactive form to send to other users for them to fill up and send it back to me and once i go into the template and save it, it will auto store it into the database that i had create in a folder at my desktop
so far the template and database transferring is working out GREAT. But i decided to do more.
Main Objective
So what i wanted to do is everytime the database updates by itself, i wanted to use the worksheet_Change function to let it auto sort by itself. So let's say if it says "Yes" at column C, i would want it to grab the whole row in the database tab and shift it to the "D" tab
And as for "No" it will shift it to "U" Tab
So i tried it on a dummy excel file and with copy and pasting it works.
BUT so i tried on the original database and the thing about template wizard is that it is not copy pasting so i dont think it works as the same like i did for manual copy and pasting.
CODE
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub
Dim cel As Range
For Each cel In Intersect(Target, Columns("C:C")).Cells
If cel.Value = "Yes" Then
With Sheets("U")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
.Range("A1:I1").Value = Rows(cel.Row).Range("A1:I1").Value
.Range("J1:AB1").Value = Rows(cel.Row).Range("AC1:AU1").Value
.Range("AC1:AE1").Value = Rows(cel.Row).Range("AV1:AX1").Value
End With
End With
ElseIf cel.Value = "No" Then
With Sheets("D")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
.Range("A1:AB1").Value = Rows(cel.Row).Range("A1:AB1").Value
.Range("AC1:AE1").Value = Rows(cel.Row).Range("AV1:AX1").Value
End With
End With
End If
Next
End Sub
Error
The error for the macro points at both
With Sheets("U")
With Sheets("D")
So if my form were to populate "Yes" The With Sheets("U") will be highlighted with error
and if i were to populate with "No" The With Sheets("D") will be highlighted with error
Might need to change Worksheet_Change to other function.. but how to make it more smart and efficient? Thanks for reading
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub
Dim cel As Range
Dim rngReceiver As Range
Dim rngDonor As Range
For Each cel In Intersect(Target, Columns("C:C")).Cells
If cel.Value = "Yes" Then
Set rngReceiver = Sheets("U").Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
rngReceiver.Resize(0, 8).Value = cel.Resize(0, 8).Value '<~ copying A:I, pasting to A1:I1
rngReceiver.Offset(0, 9).Resize(0, 18).Value = cel.Offset(0, 28).Resize(0, 18).Value '<~copying AC1:AU1 pasting to J1:AB1
rngReceiver.Offset(0, 28).Resize(0, 2).Value = cel.Offset(0, 47).Resize(0, 2).Value '<~copying AV1:AX1 pasting to AC1:AE1
ElseIf cel.Value = "No" Then
Set rngReceiver = Sheets("D").Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
rngReceiver.Resize(0, 27).Value = cel.Resize(0, 27).Value '<~ copying A1:AB1 pasting to A1:AB1
rngReceiver.Offset(0, 28).Resize(0, 2).Value = cel.Offset(0, 47).Resize(0, 2).Value '<~ copying AV1:AX1 pasting to AC1:AE1
End If
Next
End Sub
posting this answer without testing.
Related
I am working on a spreadsheet that utilizes user input to fill out a table. This data is entered into a table with numerous columns required. I have a command button that creates a new row and inserts all the data validation necessary for a new line item (below is an example.)
My problem revolves on a specific a column (blue circle) where other cells rely on based on a "yes" or "no" string. If the column has a "yes", the adjacent cells do something. If the column has a "no", the adjacent cells do something different.
As this table grows in rows, my column range I am focused on will change dynamically. I want the VBA code to run if the worksheet experiences a change event in that dynamic range utilizing the "Worksheet_Change(ByVal Target As Range) sub.
Right now, I am defining that dynamic range in my commandbutton_click sub because everytime i click the button, a new row is added thus I need the spreadsheet to be aware that my range has changed (see my code below).
Sub CommandButton1_Click()
Application.EnableEvents = False
Dim LastRowEntry As Long
Dim DeviceNo As Integer
'Dim RTUTable As Range
'Determine the last entry row & Copy
LastRowEntry = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
DeviceNo = Sheet1.Cells(Rows.Count, 1).End(xlUp)
Sheet1.Cells(Rows.Count, 1).End(xlUp).EntireRow.Copy
'Once the last row is determined, go to the next row to paste
Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormats
Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValidation
'Incase the above cell has Conditional Formatting, we set the color back to "white"
Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Interior.ColorIndex = 0
Application.CutCopyMode = False
ActiveCell.Value = DeviceNo + 1
With RTUTable
RTUTable = Sheet1.Range(("G7"), Sheet1.Cells(LastRowEntry + 1, "G"))
End With
Application.EnableEvents = True
End Sub
Then, in a different sub I enter code that will "check" to see if that dynamic range has had a change in value with a "yes" or "no" answer. This is where I enter my defined dynamic range (see my code below).
Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'This code checks to see if the Device is polled by RTU
If Not Intersect(Target, Range(RTUTable)) Is Nothing Then
If ActiveCell.Value = "NO" Then
"DO SOMETHING"
Else
"DO SOMETHING"
End If
End If
Application.EnableEvents = True
End Sub
Can someone help me out on the error message "Type mismatch" I am receiving? Am I entering the dynamic range correctly into the intersect code?
Thank you
****Update - More information for Clarification*****
I have added some information in the array I am evaluating. Below is a snapshot of my spreadsheet.
When I go into the Debug mode, I am viewing my "Locals table" and see I am successfully capturing my information in an array.
I need to run the intersect command with this array
This has been resolved. Below is the code I used to determine the dynamic range and then the code evaluates that range for a change.
Dim dyString As String
Dim dyRange As Range
Dim LastRowEntry_1 As Integer
Dim i As Integer
LastRowEntry_1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(-2, 0).row + 1
dyString = "G8:G" & LastRowEntry_1
Set dyRange = Range(dyString)
If Not Intersect(Target, dyRange) Is Nothing Then
For i = 1 To 6
If ActiveCell.Value = "NO" Then
Target.Offset(0, i).Interior.ColorIndex = 23
Target.Offset(0, i).Font.Color = vbWhite
Target.Offset(0, i).Value = "N/A"
Target.Offset(0, i).Locked = True
ElseIf ActiveCell.Value = "YES" And ActiveCell.Offset(0, i).Value = "N/A" Then
Target.Offset(0, i).Value = ""
Target.Offset(0, i).Interior.ColorIndex = 0
Target.Offset(0, i).Font.Color = vbBlack
Target.Offset(0, i).Locked = False
To summarize:
No matter what, my dynamic range will always begin at cell "G8"
After that, the range will change dynamically. Either grows or shortens depending on
the info. So my "LastRowEntry_1" determines where that last cell entry is. (Note: I
had to offset it because of some footer information on my spreadsheet)
I created a string where I could combine the range of the fixed cell to the dynamic
cell.
Then I set that string as a range.
Then based if the target range was intersected or not, I run a "For" loop to perform
my conditional formatting.
This is a continuation for the following question: What is the cause for Conditional Formatting to get jumbled up?
In an attempt to prevent my conditional formatting from going haywire, I decided to convert it into code in VBA. I decided to start small and start with converting one conditional formatting into VBA.
Explanation:
In column O there are a series of numbers, obtained from a different sheet. User inputs number in column F. For example if number in F9 is less than O9, the font colour will become red. If not number remains normal. The formula should start at row 9 and can continue down onwards and should be automatic.
Meaning the moment a number is keyed in column F the font colour should change instantly.
The following is the code I created so far:
Sub change_color()
With Me.Range("f9", Range("f" & Rows.Count).End(xlUp)) 'so the formula will carry onwards from f9 onwards
If f9 < o9 Then
Range(f).Font.Color = vbRed
End If
End With
End Sub
But alas it didn't work. I also tried linking it to a button and nothing happens. And I also remember to remove my old conditional formatting as well. Is there something I'm missing?
You are after something like the code below.
This code is to be ran once, it will lopp through the entire column "F" in your worksheet, and change the font of all instances.
Regular Module Code
Option Explicit
Sub change_color()
Dim LastRow As Long, i As Long
With Worksheets("Sheet1") ' modify to your sheet's name
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 1 To LastRow
If .Range("F" & i).Value < .Range("O" & i).Value Then
.Range("F" & i).Font.Color = vbRed
Else
.Range("F" & i).Font.Color = vbBlack
End If
Next i
End With
End Sub
To "catch" the modification in real-time, when someone changes a value in column "F", and then change the font according to the criteria you specified, you need add the following code to the Worksheet module, where you have your data, and add the piece of code below to Worksheet_Change event.
Code in Sheet1 module (modify to your sheet's)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 6 Then ' if someone changes a value in column "F"
Application.EnableEvents = False
If Target.Value < Range("O" & Target.Row).Value Then
Target.Font.Color = vbRed
Else
Target.Font.Color = vbBlack
End If
End If
Application.EnableEvents = True
End Sub
Does this work for you?
Option explicit
Sub ChangeColor()
With thisworkbook.worksheets(YOURSHEETNAME) 'Replace with sheet name as per your workbook.'
Dim LastRow as long
Lastrow = .cells(.rows.count,"F").end(xlup).row
Dim RowIndex as long
For rowindex = 9 to LastRow
If .cells(rowindex,"F").value2 < .cells(rowindex,"O").value2 then
.cells(rowindex,"F").font.color = vbred
End if
Next rowindex
End With
End Sub
I'm new to this forum but have been building up my coding experience in the last couple of months due to the VBA requirements of my current role. Today's problem has seen me trawling through many sites (and my Excel VBA for Dummies book), but I haven't quite nailed it.
I am trying to make an audit tracker file in Excel for our company Risk Register. The idea is that once the risk register is established, any changes will create an audit trail (on a separate tab) which shows both the old and the new record.
I have written the code using the Change Event handler. I want my macro to fire every time there is a change and do the following:
1. Make a reference of the old cell value (what the user has just overwritten)
2. Jump to the 'Audit trail' tab and paste two copies of the full risk record - each risk record is a row of data that occupies 17 columns
3. In the first copy of these 17 columns, work out which column was edited and replace this cell with the old cell value (captured in step 1)
4. Insert a time stamp
5. Have conditional formatting highlight the record that has changed [this function is not required in the code as I've set it up within the spreadsheet itself]
6. Jump back to cell where the user just made their edit (on the 'Risk Register' tab)
I have managed steps 1, 2 and 4-7 but I am having problems getting the code to input the "old cell value" into the right spot in the 'Audit Tracker' tab. I can get it there if I manually define the cell range for it to paste into, but I can't seem to make it dynamic so that it will automatically recognize what field the user is changing and ensure the same field is amended in the audit trail.
Would really appreciate any insights as to why the "PasteRange.Value = Worksheets("Risk Register").Range("oldValuePaste")" line isn't working
My code is as follows:
Dim oldValue As Variant
Dim LastRow As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("b13:r13")) Is Nothing Then
oldValue = Target.Value
End If
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("b13:r14")) Is Nothing Then
If Target.Value <> oldValue Then
'MsgBox "You just changed " & Target.Address
Cells(65, 5).Value = oldValue 'this cell is a named range called: OldValuePaste
Cells(66, 5).Value = Target.row 'this cell is a named range called: OldValueRowNumber
Cells(67, 5).Value = Target.Column 'this cell is a named range called: OldValueColumnNumber
Range(Cells(Target.row, 2), Cells(Target.row, 18)).Copy
'Cells(70, 2).PasteSpecial xlPasteValues
Call Paste_on_AuditSheet
Sheets("Risk Register").Activate
Target.Select
Application.CutCopyMode = False
End If
End If
Application.ScreenUpdating = True
End Sub
_____________________________________________________________________________________________________
Sub Paste_on_AuditSheet()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ColNum As Long
Dim PasteRange As Range
ColNum = OldValueColumnNumber
Sheets("Audit trail").Select
'MsgBox "Activated " & ActiveSheet.Name
'Find the last used row in a Column: column B in this example
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
End With
Set PasteRange = Cells(LastRow, ColNum)
'The following two lines bring in the new data and paste into old record and new record sections:
Cells(LastRow + 1, 2).PasteSpecial xlPasteValues
Cells(LastRow + 1, 20).PasteSpecial xlPasteValues
'Then this line goes back over the piece just pasted in and changes one cell in "old record" section to what it was prior to the edit:
'PasteRange.Value = Worksheets("Risk Register").Range("oldValuePaste")
'Above line of code is not working, but can get it to do the right thing using this code (although it's not dynamic):
Range("E3").Value = Worksheets("Risk Register").Range("oldValuePaste")
'Add a time stamp:
Cells(LastRow + 1, 1) = Now
Application.ScreenUpdating = True
End Sub
One last point - despite my repeated use of Application.ScreenUpdating commands, I still get some screen flashing - any ideas why?
Thanks in advance for the help!
In reviewing your code, I saw a few things that I didn't think would work as you supposed they would, and also recognized that your code could be made much simpler and just be called from the Worksheet_Change event.
So the refactored code below and let me know if you have issues:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("b13:r14")) Is Nothing Then
'get oldValue
Dim sNewVal As String, sOldVal As String
sNewValue = Target.Value 'store current or "new" value since this is what is stored after the cell change takes place
With Application
.EnableEvents = False 'turns off event firing so the code will not go into endless loop
.Undo 'undo the change (to store old value in next line)
End With
sOldValue = Target.Value 'store old value
Target.Value = sNewValue 'reset new value
Dim lCol As Long
lCol = Target.Column 'which column of data was changed
'assumes columns A-Q are 17 columns
Me.Range(Me.Cells(Target.Row, 1), Me.Cells(Target.Row, 17)).Copy
With Sheets("Audit Trail")
Dim lRow As Long
lRow = .Range("B" & .Rows.Count).End(xlUp).Offset(1).Row
.Range("B" & lRow).PasteSpecial xlPasteValues
.Range("B" & lRow + 1).PasteSpecial xlPasteValues
.Range("A" & lRow).Value = Now
.Cells(lRow, lCol + 1).Value = sOldValue 'store old value in first pasted line ... add 1 since starting from column B
End With
End If
Application.EnableEvents = True
End Sub
Trying to get a macro enabled worksheet on Excel to auto populate date and time when any values are entered in column B or C.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
For i = 2 To 100
If Cells(i, "B").Value <> " " And Cells(i, "C").Value = " " Then
Cells(i, "F").Value = Date & " " & Time
Cells(i, "F").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next
Range("F:F").EntireColumn.AutoFit
End Sub
is there anything wrong with the code I'm writing?
You don't want to run through all of that everytime anything on the worksheet changes; only when something that affects the validity of the timestamp changes. Typically, we would use Intersect to determine if one of the values that changed should receive a new timestamp. You also do not want the routine to attempt to run on top of itself so turning event handling off before changing a value (i.e. adding the time stamp) is recommended.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:C")) Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim bc As Range 'no sense in declaring something until we actually need it
For Each bc In Intersect(Target, Range("B:C")) 'deal with every cell that intersects. This is how to handle pastes into more than one cell
If Not IsEmpty(Cells(bc.Row, "B")) And Not IsEmpty(Cells(bc.Row, "C")) Then
Cells(bc.Row, "F").Value = Now 'Now is the equivalent of Date + Time
Cells(bc.Row, "F").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next bc
'Range("F:F").EntireColumn.AutoFit 'this slows things down. you may want to comment this out and just set an apprpriate column width that will handle everything
End If
SafeExit:
Application.EnableEvents = True
End Sub
That is my take on this old problem. There are many examples. Look toward the Related section down the right-hand side of this page for links to a few.
"Target" will be the cell(s) that changed. It is possible to change more then one cell at a time (via ctrl-enter) so checking all cells in the Target isn't a bad idea.
If you use the Intersect method it will get only the area of Target and the range you wanted to check that overlaps. This will then loop through those cells (if there are any) and if a value is found, timestamp them.
As others have mentioned, disabling events before you plug the stamps will prevent calling another worksheet change event. Just be careful when debugging not to leave events off.
You can read more about the event parameters here: https://msdn.microsoft.com/en-us/library/office/ff839775.aspx
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Excel.Range
Dim cll As Excel.Range
Set rng = Excel.Intersect(Target, Range("B:C"))
If Not (rng Is Nothing) Then
Excel.Application.EnableEvents = False
For Each cll In rng.Cells
If Len(cll.Formula) > 0 Then
Cells(cll.Row, 6).Value = Format$(Now, "m/d/yyyy h:mm AM/PM")
End If
Next
Range("F:F").EntireColumn.AutoFit
Excel.Application.EnableEvents = True
End If
End Sub
Couple of small changes:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Application.EnableEvents = False
If Target.Column = 2 Or Target.Column = 3 Then
For i = 2 To 100
If Cells(i, "B").Value <> " " And Cells(i, "C").Value = " " Then
Cells(i, "F").Value = Date & " " & Time
Cells(i, "F").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next
End If
Range("F:F").EntireColumn.AutoFit
Application.EnableEvents = True
End Sub
Turn the even off so you don't fire it when your code makes a modification and test the target column to see if it is B or C and only fire if it is
Also, you know your code will update rows 2 to 100 regardless of which row was changed right? If you only want the row that was changed you can get that with target.row
I have opened a new question after people have helped me figure out how to get my first problem fixed, now I have a new problem. You will find the coding on the "INITIATING DEVICES" page below. The idea for the second to last part of the code was to add columns (text values) from B7:b and E7:E and display it on column J7:J. So if Photo is entered into B and Pass is entered into column E then the result will be Photopass in column J. The original code works fine if run via the macro command. The problem is that I tried to add it into some of my existing code and now the whole entire program will crash when information is entered into ANY cell. The program becomes unresponsive and then it shuts down and starts up again. I don't get a code or Debug message. Here is the entire code on the page.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 7 And UCase(Target.Value) = "YES" Then
Sheets("MESSAGE CHANGES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 3).Value
Application.Goto Sheets("MESSAGE CHANGES").Cells(Rows.Count, 1).End(xlUp).Offset(, 3)
End If
If Target.Column = 6 And UCase(Target.Value) = "YES" Then
Sheets("DEVICE NOTES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 3).Value
Application.Goto Sheets("DEVICE NOTES").Cells(Rows.Count, 1).End(xlUp).Offset(, 3)
End If
'(replace if new code fails)If Target.Column = 5 And UCase(Target.Value) = "FAIL" Or Target.Column = 5 And UCase(Target.Value) = "DAMAGED" Then
'(replace if new codes fails)Sheets("FAILED DEVICES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 3).Value
If Target.Column = 5 And UCase(Target.Value) = "FAIL" Or UCase(Target.Value) = "DAMAGED" Then
Application.EnableEvents = False
Sheets("FAILED DEVICES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 5) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 5).Value
Sheets("FAILED DEVICES").Cells(Rows.Count, 1).End(xlUp).Offset(, 5) = Sheets("INITIATING DEVICES").Cells(Target.Row, 11).Value
Application.EnableEvents = True
End If
'code that will place date/time when value is selcted in E
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Range("I" & Target.Row).Value = Now
End If
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("INITIATING DEVICES")
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("J7:J" & lastRow).Value = Evaluate("=B7:B" & lastRow & "&E7:E" & lastRow)
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
With Sheets("INITIATING DEVICES")
.PageSetup.PrintArea = .Range("A1:H" & .Cells(Rows.Count, 1).End(xlUp).Row).Address
End With
End Sub
Thank you for any help that you can give me, if you need anymore information I can send the inspection file and also offer more information if needed. I'm sure I messed something up and that's why it keeps crashing. Still learning here.
IF it is crashing then the Change event is being called repeatedly. You need to use
Application.EnableEvents = False
at an appropriate point to prevent the Change event being triggered again, as you make changes (with your code) to the worksheet.