Forum Discussion

chowell97's avatar
chowell97
Copper Contributor
Aug 15, 2023
Solved

VBA

Hello,

 

I have a simple excel table with three columns, Current, Replaced, and New.

The Current column contains a specific date.

The Replaced column contains either Yes or No.

If the Replaced column has an entry of No, the date from the Current column will be written into the New column.

If the Replaced column has an entry of Yes, an input box prompt will write the users entry into the New column.

 

This is the VBA code.

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.EnableEvents = False
    Dim tbl As ListObject
    Dim N As Range
    Dim C As Range

    Dim R as Range
      Set tbl = ActiveSheet.ListObjects(1)
      Set N = tbl.ListColumns("New").DataBodyRange
      Set C = tbl.ListColumns("Current").DataBodyRange

      Set R = tbl.ListColumns("Replaced").DataBodyRange
'If R = "No" Then              ***This give a Type Mismatch runtime error and is not currently in code, but                                              was tried***
If Range("F2") = "No" Then           ***This does not give any errors***
N = C.Value
Else
N = InputBox("Please enter City, State, and ZIP of site address", "Entry is required")
End If
Application.EnableEvents = True
End Sub

 

This code kind of works as intended but with two problems I am looking for help with.

 

Problem 1: A type mismatch error is received when trying to use the line highlighted in red.

Since there can be multiple rows within the table and the number of rows will be unknown and vary in total, I cannot define a specific range as in the example code, I need the Replaced column to be looked at for the entire table.

 

Problem 2: with the example code, if there are 4 rows in the table, all 4 rows of the New column are written to when F2 changes between Yes and No.

I need the New column to have a value written to it based off of the Yes No entry for each row, not from one single row.

 

I hope these questions make sense.

 

Thanks in advance for any suggestions.

 

  • chowell97 To get a cell in an adjacent column of the table, use syntax like this:

     

    Change this line:

    Set N = tbl.ListColumns("New").DataBodyRange

    to:

    Set N = Intersect(tbl.ListColumns("New").DataBodyRange, Target.EntireRow)

    You can now use n.Value to get the value of the New column on the same row as the changed cell (Target).

    Adjust the other lines accordingly.

4 Replies

  • SnowMan55's avatar
    SnowMan55
    Bronze Contributor

    chowell97 

    Jan's technique works if the user changes only one cell at a time. But if the user changes multiple cells at once (e.g., by dragging the contents of a cell down in the Replaced column), that technique processes only the top of the changed rows (specifically, it uses only the first cell within Target).


    It's also true that your existing/modified code recalculates the New value when columns in your table other than Current or Replaced are modified (or even if a cell outside the table is modified, if it's in a row shared by a table data row).


    Consider this code instead:

    Private Sub Worksheet_Change(ByVal Target As Range)
    
      Application.EnableEvents = False
        Dim tbl As ListObject
        Dim rngChgdCurrentCells     As Range
        Dim rngChgdReplacedCells    As Range
        Dim rngChgdRelevantCells    As Range
        Dim rngCell As Range
        Dim in4Row  As Long
        Dim N As Range  'the "New" cell for a row
        Dim C As Range  'the "Current" cell for a row
        Dim R As Range  'the "Replaced" cell for a row
        Dim strUserResponse As String
        
        '----
        On Error GoTo WkshtChg_ErrHndlr
        
        '----   In "the table" [description?], calculate/recalculate the
        '       New value in rows where either the Current value or the
        '       Replaced value changed.
        '  --   Determine if any of the changed cells are relevant to
        '       the calculation of a New value.
        Set tbl = ActiveSheet.ListObjects(1)
        Set rngChgdCurrentCells = Intersect(Target, _
                tbl.ListColumns("Current").DataBodyRange)
        Set rngChgdReplacedCells = Intersect(Target, _
                tbl.ListColumns("Replaced").DataBodyRange)
        If rngChgdCurrentCells Is Nothing _
        And rngChgdReplacedCells Is Nothing Then
            '...the changed cell(s) is/are not relevant.
            GoTo WkshtChg_Exit
        End If
        '  --   Load references to all relevant changed cells into a
        '       single variable.
        If rngChgdCurrentCells Is Nothing Then
            Set rngChgdRelevantCells = rngChgdReplacedCells
        ElseIf rngChgdReplacedCells Is Nothing Then
            Set rngChgdRelevantCells = rngChgdCurrentCells
        Else
            '...(it's unlikely, but) both types of cells were changed.
            Set rngChgdRelevantCells = Union( _
                    rngChgdCurrentCells, rngChgdReplacedCells _
                )
        End If
        '  --   Examining each changed relevant cell, calculate a New value
        '       in the same row.
        For Each rngCell In rngChgdRelevantCells
            in4Row = rngCell.Row
            Set C = Intersect(rngCell.EntireRow, tbl.ListColumns("Current").DataBodyRange)
            Set R = Intersect(rngCell.EntireRow, tbl.ListColumns("Replaced").DataBodyRange)
            Set N = Intersect(rngCell.EntireRow, tbl.ListColumns("New").DataBodyRange)
            '
            If IsEmpty(R.Value) Then
                '...Replaced value has not been entered.  Do nothing. [?]
            ElseIf R.Value = "No" Then
            '   [...use that for a case-sensitive test; if case does not matter, use:
            'ElseIf StrComp(R.Value, "No", vbTextCompare) = 0 Then
                N.Value = C.Value
            Else
                'Because "Entry is required", prompt until a non-empty response is
                'received.
                Do
                    strUserResponse = InputBox("Please enter City, State, and ZIP of" _
                            & " site address", "Entry is required")
                Loop Until Len(strUserResponse) > 0
                N.Value = strUserResponse
            End If
        Next rngCell
        
    WkshtChg_Exit:
        Application.EnableEvents = True
        Exit Sub
    
    WkshtChg_ErrHndlr:
        Dim in4ErrorCode    As Long
        Dim strErrorDescr   As String
        Dim strMessage      As String
        Dim in4UserResponse As VbMsgBoxResult
        '  --   Capture info about the processing error.
        in4ErrorCode = Err.Number
        strErrorDescr = Err.Description
        '  --   Notify the user.
        strMessage = "Error " & in4ErrorCode & " occurred while processing row " _
                & Format$(in4Row, "#,###,##0") & vbCrLf & strErrorDescr
        in4UserResponse = MsgBox(strMessage, vbRetryCancel)
        '  --
        If in4UserResponse = vbRetry Then
            Resume
        Else
            Resume WkshtChg_Exit
        End If
    End Sub


    I've included an example of a simple error handler.


    Note that your test for "No" is case-sensitive. I included commented-out code for an alternative, case-insensitive test.

     

    I also wrapped the prompt for site address in a Do loop, as the prompt title indicates "Entry is required". (But as written, the user could defeat this by just entering a space.)


    And let me point out that it is generally poor design to put multiple types of values into one table column, as you have done putting both a date value and a site address into New. This may be completely functional, but it may also make future usage and/or modifications more difficult.

     

    • chowell97's avatar
      chowell97
      Copper Contributor
      Thank you for the additional information including the error handler example.

      Also, thank you for pointing out the multiple types of values I was referencing.
      This was actually a line of code copied from another worksheet that writes address information into different table columns and was not corrected for this particular table prior to posting.
  • JKPieterse's avatar
    JKPieterse
    Silver Contributor

    chowell97 To get a cell in an adjacent column of the table, use syntax like this:

     

    Change this line:

    Set N = tbl.ListColumns("New").DataBodyRange

    to:

    Set N = Intersect(tbl.ListColumns("New").DataBodyRange, Target.EntireRow)

    You can now use n.Value to get the value of the New column on the same row as the changed cell (Target).

    Adjust the other lines accordingly.

    • chowell97's avatar
      chowell97
      Copper Contributor
      Thank you Jan, this so far has corrected my issues.

Resources