Potential VBA solution for wanting a cell to update its manually inputed contents once data is entered in another cell - excel

I want data in the cells of column J to copy the data in the cells of column G once data is inputted into column G and not before.
However, prior to this replication taking place I would like to be able to manually update the price in the cells of column J.
See the attached photo for clarity.
Could anyone suggest a solution? I know VBA is a possibility, however, my Excel knowledge is not good enough to write code.
Yellow headings represent no formulas and blue represent formulas.
Excel_Worksheet_ TRADE LOG
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("C:C"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("G:G"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 12).ClearContents
Else
With .Offset(0, 12)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub

A Simple Worksheet Change
If values in the column range from G2 to the bottom-most (last) cell of the worksheet, are changed manually or via code, the values of the cells in the corresponding rows in column J will be overwritten with the values from column G.
This solution is automated, you don't run anything.
Sheet Module e.g. Sheet1 (in parentheses in Project Explorer of Visual Basic Editor)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const sCell As String = "G2" ' Source First Cell
Const dCol As Variant = "J" ' Destination Column Id (String or Index)
Dim irg As Range ' Intersect Range
Dim cOffset As Long ' Column Offset
With Range(sCell)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
If irg Is Nothing Then Exit Sub
cOffset = Columns(dCol).Column - .Column
End With
Dim arg As Range ' Current Area of Intersect Range
Dim cel As Range ' Current Cell in Current Area of Intersect Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If Not IsError(cel.Value) Then
cel.Offset(, cOffset).Value = cel.Value
End If
Next cel
Next arg
End Sub

Related

Using target offset to clear a range of cells in excel

I'm trying to clear a range of 5 cells when changing another. For example: H5 is changed, J5:J10 is cleared. This works a treat in clearing J5 when H5 is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Left(Target.Address(, False), 1) = "H" Then Target.Offset(, 2).ClearContents
End Sub
However this does not clear the 4 cells below. I was wary of using a function to specify the range as I've got multiple rows of data in H. So for example if H24 changes, J24:J29 are cleared, which goes on for about 200 rows...
Any help is appreciated!
The Offset-function returns a range with the same size than the original Range, just at a different place. To increase (or decrease) the size of a range, you can use the Resize-function. So basically, you need to combine both functions.
I don't want to argue with you about how to check for the column, but I think using If Target.Column = 8 Then is much easier.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then ' Col H
Dim destRange As Range
Set destRange = Target.Offset(0, 2).Resize(5, 1)
Debug.Print destRange.Address
destRange.ClearContents
End If
End Sub
Be aware that Target may contain more than one cell (eg via Cut&Paste), you probably need to handle that.
This should do it.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
Application.EnableEvents = True
End Sub
Okay with merged cells offset gets weird and even offsetting the topleft cell of the merged area (Target.MergeArea(1, 1)) will give bad results so we need to create the range ourselves.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.MergeCells = True Then
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(0, 2), ActiveSheet.Cells(Target.MergeArea(1, 1).Row + 5, Target.MergeArea(1, 1).Offset(0, 2).Column)).ClearContents
Else
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
End If
Application.EnableEvents = True
End Sub
I hardcoded the 5 into the row change if you need it to be the size of the merged area you will need to get the difference in rows from the top to the bottom of the merged area.
Clear Cells on Any Side of Merged Cells
The colors in the image show which contents will be cleared in column J if a value in a cell in column H is changed (manually or via VBA).
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim doEnableEvents As Boolean
On Error GoTo clearError
Const FirstCellAddress As String = "H2"
Const ColOffset As Long = 2
Dim irg As Range
With Range(FirstCellAddress)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If Not irg Is Nothing Then
Application.EnableEvents = False
doEnableEvents = True
Dim arg As Range
Dim cel As Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If cel.MergeCells Then
With cel.MergeArea
.Cells(1, 1).Offset(, ColOffset).Resize(.Rows.Count) _
.ClearContents
End With
Else
cel.Offset(, ColOffset).ClearContents
End If
Next cel
Next arg
End If
ProcExit:
If doEnableEvents Then
Application.EnableEvents = True
End If
Exit Sub
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Sub testMultiArea()
Dim rg As Range: Set rg = Range("H2,H7")
rg.Value = 500
End Sub

Find previous cell address (to the left) in active row with different value than active cell value

I,ve tried to find a VBA solution for finding the previous cell (located on the same row) with different value than the selected cell has. So if the selected cell is for example [N6] (as in my picture) then my search range should be ("A6:N6") from which I need to find the last cell with a different cell value (which would be cell [L6] in my picture because it's the previous cell with a different value than cell [N6]. The search should start from the end (N6,M6,L6...) backwards until the first match is found (first different cell value). When the first match is found then select it. I have hundreds of columns, so my picture is just to show the principle. I execute my vba code with Private Sub Worksheet_SelectionChange(ByVal Target As Range) so when the user selects a cell with the mouse. I get the desired cell with {=ADDRESS(6;MATCH(2;1/(A6:O6<>"D")))} but I would need a VBA solution for my problem. My current VBA solution takes me to cell [I6] instead of [L6] and I can't figure out how to edit my code to find the correct cell ([L6] in my example picture).
Dim rngSel As String, rngStart As String
Dim rngActiveStart As Range
rngSel = ActiveCell.Address(0, 0)
rngStart = Cells(ActiveCell.Row, 1).Address(0, 0)
Set rngActiveStart = Range(rngStart & ":" & rngSel)
Dim c
For Each c In rngActiveStart.Cells
If c <> Target.Value And c.Offset(0, 1) = Target.Value Then
c.Select
MsgBox "Previous different cell: " & c.Address(0, 0)
Exit For
End If
Next
Using selection_Change
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Long, col As Long, x
Dim v As String
r = Target.Row
v = Target.Value
Application.EnableEvents = False
For x = Target.Column To 1 Step -1
With Me
If .Cells(r, x) <> v Then
.Cells(r, x).Select
Exit For
End If
End With
Next x
Application.EnableEvents = True
End Sub
You need a For i = max To min Step -1 loop to loop backwards/left:
Public Sub MoveLeftUntilChange()
Dim SelRange As Range 'remember the selected range 'N6
Set SelRange = Selection
Dim iCol As Long
For iCol = SelRange.Column To 1 Step -1 'move columns leftwards
With SelRange.Parent.Cells(SelRange.Row, iCol) 'this is the current row/column to test againts the remembered range N6
If .Value <> SelRange.Value Then 'if change found select and exit
.Select
Exit For
End If
End With
Next iCol
End Sub

Record Date values based on another cell's value

I am a beginner in VBA.
I have a Column "A" can have multiple values, of which 2 are "Impact Assessed" or "Ready for retesting".
Problem Statement - I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively.
Below is my code -
Private Sub Worksheet_Calculate()
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("AA:AA"), Target)
If Not rng Is Nothing Then
Select Case (rng.Value)
Case "2 - Impact Assessed": rng.Offset(0, 1).Value = Date
Case "4 - Ready for retesting": rng.Offset(0, 2).Value = Date
End Select
End If
End Sub
I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the Criteria variable to suit your worksheet and you can change your sheet as you like without needing to modify the code.
Private Sub Worksheet_Change(ByVal Target As Range)
' 040
Const TriggerClm As String = "A" ' change to suit
Const WriteToClm As String = "B" ' the second one is next to this
Dim Rng As Range ' working range
Dim C As Long ' WriteToClm
Dim Criteria() As String ' selected values from TriggerClm
Dim i As Integer ' index to Criteria()
' don't respond to changes of multiple cells such as Paste or Delete
If Target.CountLarge > 1 Then Exit Sub
' respond to changes in cells from row 2 to
' one cell below the last used row in the trigger column
Set Rng = Range(Cells(2, TriggerClm), _
Cells(Rows.Count, TriggerClm).End(xlUp).Offset(1))
If Not Application.Intersect(Rng, Target) Is Nothing Then
' intentionally all lower case because comparison
' is carried out case insensitive
' First item's date is in WriteToClm
Criteria = Split("impact assessed,ready for retesting", ",")
For i = UBound(Criteria) To 0 Step -1
If StrComp(Target.Value, Criteria(i), vbTextCompare) = 0 Then Exit For
Next i
' i = -1 if no match was found
If i >= 0 Then
C = Columns(WriteToClm).Column + i
Cells(Target.Row, C).Value = Date
End If
End If
End Sub
You can use something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("A:A"), Target)
If Not rng Is Nothing Then
For Each c in rng.cells
Select Case LCase(c.Value)
Case "impact assessed": c.Offset(0, 1).Value = Date
Case "ready": c.Offset(0, 2).Value = Date
End Select
Next c
End If
End Sub
FYI = Range(Target.Address) is the same (in this case) as Target - no need to get the address just to turn that back into a range.

MSG Macro on Sheet change if offset value = TRUE

I would like to display a msgbox if the formula fuelled cell in column I:I changes to TRUE after the cell in column D:D is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
myRange = Range("D:D")
If Intersect(myRange, Target) Then
If Target.Offset(0, 3).Value = True Then MsgBox "Date Range and Holiday Type Mismatch"
End If
End Sub
This is an exaxmple of the table. Basically i will update column D:D with the holiday type. In column I:I the cell will change to TRUE if the date range is not acceptable. If the cell in column I:I changes to TRUE i want the msg box to display.
A good starting attempt, but several issues, including the need for Set when working with Range objects, and an offset that seems... off.
Here's one approach:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Set myRng = Intersect(Target, Me.Columns("D:D"))
If myRng Is Nothing Then Exit Sub
Dim myCell As Range
For Each myCell In myRng
If Me.Cells(myCell.Row, "I").Value = True Then
MsgBox "Date Range and Holiday Type Mismatch"
End If
Next
End Sub

Hide/Unhide a row based on the hidden/unhidden status of a range of cells

I want to unhide a single row if an ENTIRE range of rows is hidden. I want to hide this row if even a SINGLE row within the range is unhidden. What is the syntax for this? My current code is as follows:
Public Sub MySub()
Application.ScreenUpdating = False
With Range("A1:A5")
.EntireRow.Hidden = False
For Each cell In Range("A1:A5")
Select Case cell.Value
Case Is = "-"
cell.EntireRow.Hidden = True
End Select
Next cell
End With
Application.ScreenUpdating = True
End Sub
I think I understand. How's this:
Sub test()
Dim cel As Range, rng As Range
Dim hideRow&, numDashes&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
For Each cel In rng
If cel.Value = "-" Then
numDashes = numDashes + 1
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
If numDashes = rng.Count Then
' If all cells in the range are '-'
Rows(hideRow).EntireRow.Hidden = False
Else
Rows(hideRow).EntireRow.Hidden = True
End If
End Sub
I'm kind of assuming that you want to hide/unhide Row 6, since it's one below your range's last row. Therefore, I created a variable to hold this. This way, if you want to change your range to say A1:A100, all you have to do is adjust the rng, and it'll look to hide/unhide row 101. Of course, if you just need it to be 6, then just do hideRow = 6.
Edit: For fun, I tried to reduce the use of the counting variable numDashes and tried to the part where you check your range for all - to be more concise. The below should work too, but might need a tweak or two:
Sub test2()
Dim cel As Range, rng As Range
Dim hideRow&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
'Check to see if your range is entirely made up of `-`
If WorksheetFunction.CountIf(rng, "-") = rng.Count Then
Rows(hideRow).EntireRow.Hidden = False
' If you want to stop your macro if ALL range values are "-", then uncomment the next line:
'Exit Sub
Else
Rows(hideRow).EntireRow.Hidden = True
End If
For Each cel In rng
If cel.Value = "-" Then
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
End Sub
You can do this with a formula in a helper column. I used this one for financial statements to suppress rows where multiple column are all zero to shorten up the report.
=IF(AND(SUM(A7:R7)<1,SUM(A7:R7)>-1),IF(OR(ISNUMBER(LEFT(H7,4)),ISBLANK(H7),ISERR(VALUE(LEFT(H7,4)))),"Show","Hide"),"Show").
Then filter the rows by that column.

Resources