Trevor3007
Well-known Member
- Joined
- Jan 26, 2017
- Messages
- 675
- Office Version
- 365
- Platform
- Windows
Hi,
Using the spreadsheet as shown above, this is the code behind:-
It works great, but would prefer rather than picking from the drop down list (Part Kit, col k, which is in a 'drop down' list) it would do this upon entering the retrospective number 1. This spreadsheet is used as a inventory. Which has 500+ entries to be done for each office, on every floor througtout the complete estate. So anything that can speed up the process is a bonus.
My sincere thanks goes out to the person(s) who likes a challenge & can sort this for me / team.
| HMRC RTO Survey Sheet V2_Preston.xlsm | |||||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | H | I | J | K | L | M | |||
| 3 | |||||||||||||||
| 4 | Required | ||||||||||||||
| 5 | Rm | Floor | Desk | Dock | USB3 | K/B | Mouse | Monitor | HDMI/DVI | DVI/DVI | Note / Comments | Date | |||
| 6 | 1000 | 10 | N K | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 7 | 1000 | 10 | 50 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 8 | 1000 | 10 | 51 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 9 | 1000 | 10 | 49 | 1 | 1 | Part Kit | 07/07/2021 | ||||||||
| 10 | 1000 | 10 | 8 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||||
| 11 | 1000 | 10 | 17 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||||
| 12 | 1000 | 10 | 54 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||||
| 13 | Main Office | 10 | 25 | No Kit | 07/07/2021 | ||||||||||
| 14 | Main Office | 10 | N K | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 15 | Main Office | 10 | 41 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 16 | Main Office | 10 | 40 | 1 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||
| 17 | Main Office | 10 | 39 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 18 | Main Office | 10 | 37 | 1 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||
| 19 | Main Office | 10 | 36 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 20 | Main Office | 10 | 35 | 1 | 1 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||
| 21 | Main Office | 10 | 34 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 22 | Main Office | 10 | 33 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 23 | Main Office | 10 | 32 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
| 24 | Main Office | 10 | 30 | 1 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||
| 25 | Main Office | 10 | 29 | 1 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | |||||
| 26 | Main Office | 10 | 28 | 1 | 1 | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||
| 27 | P11 | 10 | N K | 1 | 1 | 1 | 1 | Part Kit | 07/07/2021 | ||||||
Site Survey | |||||||||||||||
| Cell Formulas | ||
|---|---|---|
| Range | Formula | |
| A15:A26,B15:B27 | A15 | =IF(A14>0,A14,"") |
| Cells with Data Validation | ||
|---|---|---|
| Cell | Allow | Criteria |
| K6:K27 | List | =DropDown!$A$2:$A$5 |
Using the spreadsheet as shown above, this is the code behind:-
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 SubIt works great, but would prefer rather than picking from the drop down list (Part Kit, col k, which is in a 'drop down' list) it would do this upon entering the retrospective number 1. This spreadsheet is used as a inventory. Which has 500+ entries to be done for each office, on every floor througtout the complete estate. So anything that can speed up the process is a bonus.
My sincere thanks goes out to the person(s) who likes a challenge & can sort this for me / team.
