Applying this code to additional columns

tmpollard · Mar 31st 2016

Code works for columns C & D, want to make the code work for columns H & I. Thanks

Code

Private Sub WorkSheet_Change(ByVal Target As Range)
Dim x As Range, y As Long
If Not Intersect(Target, Columns("C:D")) Is Nothing Then
    Select Case Target.Column
    Case Is = 4
    y = Cells(Rows.Count, 4).End(3).Row
        For Each x In Range(Cells(2, 4), Cells(y, 4))
            If x.Value <> "" And x.Offset(, -1) <> "" Then
                x.Offset(, -2) = x / x.Offset(, -1)
            Else
                x.Offset(, -2) = ""
            End If
        Next x
    Case Is = 3
    y = Cells(Rows.Count, 3).End(3).Row
        For Each x In Range(Cells(2, 3), Cells(y, 3))
            If x.Value <> "" And x.Offset(, 1) <> "" Then
                x.Offset(, -1) = x.Offset(, 1) / x
            Else
                x.Offset(, -1) = ""
            End If
        Next x
    End Select
End If
End Sub

Display More

[ATTACH=CONFIG]68733[/ATTACH]

skywriter · Apr 1st 2016

Re: Applying this code to additional columns

Maybe this. :cool:

Code

Private Sub WorkSheet_Change(ByVal Target As Range)
    Dim x As Range, y As Long
    If Not Intersect(Target, Range("C:D,H:I")) Is Nothing Then
    
        Select Case Target.Column
        Case Is = 4, 9
            y = Cells(Rows.Count, Target.Column).End(3).Row
            For Each x In Range(Cells(2, Target.Column), Cells(y, Target.Column))
                If x.Value <> "" And x.Offset(, -1) <> "" Then
                    x.Offset(, -2) = x / x.Offset(, -1)
                Else
                    x.Offset(, -2) = ""
                End If
            Next x
        Case Is = 3, 8
            y = Cells(Rows.Count, Target.Column).End(3).Row
            For Each x In Range(Cells(2, Target.Column), Cells(y, Target.Column))
                If x.Value <> "" And x.Offset(, 1) <> "" Then
                    x.Offset(, -1) = x.Offset(, 1) / x
                Else
                    x.Offset(, -1) = ""
                End If
            Next x
        End Select
    End If

Display More

tmpollard · Apr 1st 2016

Re: Applying this code to additional columns

Thanks for your help.
I added two more sets of columns to fill out my sheet. There was one issue with the code, every time I pressed delete to delete one of the numbers I get a run-time error '13'.

The other thing I would like to do is for each grouping to perform a different type of calculation so:
C&D would be addition
H&I would be subtraction
M&N would be multiplication
R&S would be division

Code

Private Sub WorkSheet_Change(ByVal Target As Range)
    Dim x As Range, y As Long
    If Not Intersect(Target, Range("C:D,H:I,M:N,R:S")) Is Nothing Then
         
        Select Case Target.Column
        Case Is = 4, 9, 14, 19
            y = Cells(Rows.Count, Target.Column).End(3).Row
            For Each x In Range(Cells(2, Target.Column), Cells(y, Target.Column))
                If x.Value <> "" And x.Offset(, -1) <> "" Then
                    x.Offset(, -2) = x / x.Offset(, -1)
                Else
                    x.Offset(, -2) = ""
                End If
            Next x
        Case Is = 3, 8, 13, 18
            y = Cells(Rows.Count, Target.Column).End(3).Row
            For Each x In Range(Cells(2, Target.Column), Cells(y, Target.Column))
                If x.Value <> "" And x.Offset(, 1) <> "" Then
                    x.Offset(, -1) = x.Offset(, 1) / x
                Else
                    x.Offset(, -1) = ""
                End If
            Next x
        End Select
    End If
End Sub

Display More

skywriter · Apr 1st 2016

Re: Applying this code to additional columns

I helped you with your original request.

If you want to start adding other things and changing things then I suggest you start a new post.

Grimes0332 · Apr 1st 2016

Re: Applying this code to additional columns

http://www.excelforum.com/exce…ode-for-more-columns.html

Applying this code to additional columns

Participate now!

Share