insert 'Part Kit'

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
675
Office Version
  1. 365
Platform
  1. Windows
hi,

I use the following code


VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)


Application.ScreenUpdating = False
    Dim rng As Range
       
    For Each rng In Range("k2:k1500")
        Select Case rng.Value
            Case "Part Kit"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 7
                    .Font.Bold = True
                End With
                
            Case "Full Kit"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 4
                    .Font.Bold = True
                End With
            Case "No Kit"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 6
                    .Font.Bold = True
                End With
            Case "Device Not Received"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 28
                    .Font.Bold = True
                End With
            Case "Emailed Requested For SCCM Check"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 38
                    .Font.Bold = True
                End With
            Case "Desktop UAD - On Hold ATM"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 44
                    .Font.Bold = True
                End With
            Case "Device With Build Engineer"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 40
                    .Font.Bold = False
                End With
            Case ""
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
        End Select
    Next rng
    Application.ScreenUpdating = True

Const BINARY_RANGE      As String = "d6:J999"
    Const COMMENTS_RANGE    As String = "K6:K999"

    Const PLACEHOLDER       As String = "$@#@$"
    Const MESSAGE           As String = "Cell $@#@$ Only 1 Is Allowed!"
    
    Dim Act As Boolean
    Dim c   As Range
    
    Application.EnableEvents = False
    For Each c In Target
        Act = False
        If Not Application.Intersect(c, Range(BINARY_RANGE)) Is Nothing Then
            If IsError(c.Value) Then
                Act = True
            ElseIf c.Value = vbNullString Then
                ' do nothing
            Else
                If c.Value <> 0 And c.Value <> 1 Then
                    Act = True
                End If
            End If
            If Act Then
                c.Value = vbNullString
                MsgBox Replace(MESSAGE, PLACEHOLDER, c.Address)
            End If
        End If
    Next c
    For Each c In Target
        If Not Application.Intersect(c, Range(COMMENTS_RANGE)) Is Nothing Then
            If IsError(c.Value) Then
                c.Offset(0, 1).Value = vbNullString
            Else
                If Len(c.Value) = 0 Then
                    c.Offset(0, 1).Value = vbNullString
                Else
                    c.Offset(0, 1).Value = Date
                End If
            End If
        End If
    Next c
    Application.EnableEvents = True



If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub



    On Error Resume Next

    If Not Intersect(Target, Range("jb2:jb100")) Is Nothing Then

        Application.EnableEvents = False

        Target = UCase(Target)

        Application.EnableEvents = True

    End If
      

    On Error GoTo 0


If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub


    On Error Resume Next

    If Not Intersect(Target, Range("b1:b1")) Is Nothing Then

        Application.EnableEvents = False

        Target = StrConv(Target, vbProperCase)

        Application.EnableEvents = True

    End If

    On Error GoTo 0
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub


    On Error Resume Next

    If Not Intersect(Target, Range("k")) Is Nothing Then

        Application.EnableEvents = False

        Target = StrConv(Target, vbProperCase)

        Application.EnableEvents = True

    End If

    On Error GoTo 0
    
    
    
 If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub



    On Error Resume Next

    If Not Intersect(Target, Range("d1:d100")) Is Nothing Then

        Application.EnableEvents = False

        Target = LCase(Target)

        Application.EnableEvents = True

    End If

    On Error GoTo 0
    
    
    
       
    
End Sub


survey.jpg


Col K (k5) which contains a drop down . Mostly its 'Part Kit' is the user choice .Can some person who has the VB knowledge add into the above VB so if a 1 is inserted in to the any cell within the range ,
d5:j200, the retrospective cell range K5:k2000, will auto insert 'Part Kit'?

Many thanks for your help.
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
VBA Code:
    If Not (Intersect(Target, Range("D5:J2000")) Is Nothing) And (Target = "1") Then Range("K" & Target.Row) = "Part Kit"
 
Upvote 0
VBA Code:
    If Not (Intersect(Target, Range("D5:J2000")) Is Nothing) And (Target = "1") Then Range("K" & Target.Row) = "Part Kit"
Thanks JohnnyL,

that does work..but

Before 1 inserted

1628708744460.png



After 1 inserted

1628708987976.png





after 1 removed

1628709422928.png



But it should return to:-

1628708744460.png
 
Upvote 0
It should? I didn't see where you specified that previously.
 
Upvote 0
See if this handles your second wish:

VBA Code:
    If Not (Intersect(Target, Range("D5:J2000")) Is Nothing) Then
        If Application.WorksheetFunction.CountBlank(Range("D" & Target.Row & ":J" & Target.Row)) = 7 Then Range("K" & Target.Row) = ""
    End If
 
Upvote 0
See if this handles your second wish:

VBA Code:
    If Not (Intersect(Target, Range("D5:J2000")) Is Nothing) Then
        If Application.WorksheetFunction.CountBlank(Range("D" & Target.Row & ":J" & Target.Row)) = 7 Then Range("K" & Target.Row) = ""
    End If
thanks for your swift reply.. I added your code, but sorry it does not work correctly(see fig 1).

fig 1
1628713132800.png


however if I choose I manually choose "part kit from the drop down (see fig 2)

fig 2

1628713706851.png


it works.


and clearing the cell (fig3 )

fig 3

1628713806060.png



VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)


Application.ScreenUpdating = False
    Dim rng As Range
       
    For Each rng In Range("k2:k1500")
        Select Case rng.Value
            Case "Part Kit"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 7
                    .Font.Bold = True
                End With
                
            Case "Full Kit"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 4
                    .Font.Bold = True
                End With
            Case "No Kit"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 6
                    .Font.Bold = True
                End With
            Case "Device Not Received"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 28
                    .Font.Bold = True
                End With
            Case "Emailed Requested For SCCM Check"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 38
                    .Font.Bold = True
                End With
            Case "Desktop UAD - On Hold ATM"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 44
                    .Font.Bold = True
                End With
            Case "Device With Build Engineer"
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = 40
                    .Font.Bold = False
                End With
            Case ""
                With Range("A" & rng.Row).Resize(1, 12)
                    .Interior.ColorIndex = xlNone
                    .Font.Bold = False
                End With
        End Select
    Next rng
    Application.ScreenUpdating = True

Const BINARY_RANGE      As String = "d6:J999"
    Const COMMENTS_RANGE    As String = "K6:K999"

    Const PLACEHOLDER       As String = "$@#@$"
    Const MESSAGE           As String = "Cell $@#@$ Only 1 Is Allowed!"
    
    Dim Act As Boolean
    Dim c   As Range
    
    Application.EnableEvents = False
    For Each c In Target
        Act = False
        If Not Application.Intersect(c, Range(BINARY_RANGE)) Is Nothing Then
            If IsError(c.Value) Then
                Act = True
            ElseIf c.Value = vbNullString Then
                ' do nothing
            Else
                If c.Value <> 0 And c.Value <> 1 Then
                    Act = True
                End If
            End If
            If Act Then
                c.Value = vbNullString
                MsgBox Replace(MESSAGE, PLACEHOLDER, c.Address)
            End If
        End If
    Next c
    For Each c In Target
        If Not Application.Intersect(c, Range(COMMENTS_RANGE)) Is Nothing Then
            If IsError(c.Value) Then
                c.Offset(0, 1).Value = vbNullString
            Else
                If Len(c.Value) = 0 Then
                    c.Offset(0, 1).Value = vbNullString
                Else
                    c.Offset(0, 1).Value = Date
                End If
            End If
        End If
    Next c
    Application.EnableEvents = True



If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub



    On Error Resume Next

    If Not Intersect(Target, Range("jb2:jb100")) Is Nothing Then

        Application.EnableEvents = False

        Target = UCase(Target)

        Application.EnableEvents = True

    End If
      

    On Error GoTo 0


If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub


    On Error Resume Next

    If Not Intersect(Target, Range("b1:b1")) Is Nothing Then

        Application.EnableEvents = False

        Target = StrConv(Target, vbProperCase)

        Application.EnableEvents = True

    End If

    On Error GoTo 0
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub


    On Error Resume Next

    If Not Intersect(Target, Range("k")) Is Nothing Then

        Application.EnableEvents = False

        Target = StrConv(Target, vbProperCase)

        Application.EnableEvents = True

    End If

    On Error GoTo 0
    
    
    
 If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub



    On Error Resume Next

    If Not Intersect(Target, Range("d1:d100")) Is Nothing Then

        Application.EnableEvents = False

        Target = LCase(Target)

        Application.EnableEvents = True

    End If

    On Error GoTo 0
    
   [COLOR=rgb(235, 107, 86)] If Not (Intersect(Target, Range("D6:J2000")) Is Nothing) Then
        If Application.WorksheetFunction.CountBlank(Range("D" & Target.Row & ":J" & Target.Row)) = 7 Then Range("K" & Target.Row) = ""
    End If
   [/COLOR] 
            
    
End Sub



Not knowing exactly where to place your code, I inserted as shown in the '[COLOR=rgb(209, 72, 65)]red[/COLOR][COLOR=rgb(0, 0, 0)]' text above.


many thanks agin.[/COLOR]
 
Upvote 0
I have a sneaky suspicion that your code is preventing my code from being executed.

Try placing both of the codes I provided, the code from post #2 and the code from Post #6 at the top of your code, right below the 'Dim' line.

The codes work flawlessly for me.
 
Upvote 0
Solution
wahoooo.

thank you, great work. Its now running as it should (y)
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top