Protect cells, Copy Entries

[lui_roc]

Hi all,

I have to confess I am not an expert when it comes to VB (you'll probably be pulling your hair out when you see me code!), actually far from it. Anyway I've managed to put together a spreadsheet, which evaluates risk, by spending a lot of time on it and seeking help from the forum. I am now at a stage where I have nearly finished and a have two problems I'm unable to solve.

I think the problems are very specific to the spreadsheet so I?ve attached to this post.

Problem No.1 - I want the cells in column A (starting from A7) on the RiskRegister spreadsheet to be locked, until the user selects from the drop down list. This sound quite straight forward right? Not quite, when the user selects the custom option it asks the user to enter risk source (via a msgbox) and the entry is added to the cell. Basically, I want the user to use the drop down list and not to add a custom entry directly into the cell without selecting custom from the list. I did solve this issue in v2000 however it failed on v2003.

Problem No.2 - Again this problem sounds quite straight forward but because of way the spreadsheet operates it?s slightly more complicated, I think! When the user selects a risk source from A7:A it imports data from another worksheet. The risk source name appears in the cell that was used to select the source and the risks associated to this source are entered B. like so:

______A________ B
1____Bridge_____Foundations
2 ____________Erections

I would like to the risk source (that that appears in A1) to be shown beside all risks (i.e. A2)
This should be easy however I have tried to automatically copy it down but by doing this it activates the import process.

I would be most grateful for any help

Lui

[mdmackillop]

Hi Lui,
Re Q1, You have The sheet protected. You'll need to add a button to unprotect the sheet to permit any changes

[mdmackillop]

Your code seems to be looping due to change events. If you step through the code, you should be able to spot these loops and set Enables accordingly. Generally this should not be used in routines only called by others, as the parent routine can control the enabled events and it avoids confusion.
Regards
MD
Q2
[vba]
Sub GetRisks(Target As Range)
ActiveSheet.Unprotect
On Error GoTo ars_exit:
'Application.EnableEvents = False

Dim rFound As Range
Dim Rw As Long, i As Long
Set rFound = Sheets("RiskSource").Columns("B:B").Find(What:=Target, _
After:=[b1], LookIn:=xlFormulas, LookAt:=xlWhole)

If Target = "Custom" Then
Target = InputBox("Enter risk source")
Rw = InputBox("Rows required")
Target.Offset(1).Range("A1:A" & Rw).EntireRow.Insert
Target.Offset(-1, 1).Range("A1:AC" & Rw + 1).FillDown
'********************************************
Target.Range("A1:A" & Rw).FillDown
Target.Range("C1" & Rw).ClearContents
Target.Range("Q1:Q" & Rw).ClearContents
Else
Rw = rFound.End(xlDown).Row
'Correct for last item
If Rw = Cells.Rows.Count Then
Rw = Sheets("RiskSource").Cells(Cells.Rows.Count, 3).End(xlUp).Row
Rw = Rw - rFound.Row + 1
Else
Rw = Rw - rFound.Row
End If

Target.Offset(1).Range("A1:A" & Rw).EntireRow.Insert
Target.Offset(-1, 1).Range("A1:AH" & Rw + 1).FillDown
For i = 0 To Rw - 1
Target.Offset(i, 2) = rFound.Offset(i, 2)
Target.Offset(i, 3) = rFound.Offset(i, 3)
Target.Offset(i, 4) = rFound.Offset(i, 1)
Target.Offset(i, 16) = rFound.Offset(i, 4)
Target.Range("F1:J" & Rw).ClearContents
Target.Range("M1:N" & Rw).ClearContents
Target.Range("R1:AD" & Rw).ClearContents
Target.Range("AG1:AG" & Rw).ClearContents
Next i
'********************************
Target.Range("A1:A" & Rw).FillDown
End If

ActiveSheet.Range("B7").Copy
ActiveSheet.Range("B7").PasteSpecial
ActiveSheet.Range("a7:a1000").Columns.AutoFit

Set LastUpdatedCell = Target
LastUpdatedTime = Now
Target.Select
ars_exit:
Application.EnableEvents = True

ActiveSheet.Range("B7").Copy
ActiveSheet.Range("B7").PasteSpecial
Set LastUpdatedCell = Target
LastUpdatedTime = Now
Target.Select


'ActiveSheet.Protect

End Sub

[/vba]

[lui_roc]

MD - thanks for looking at these problems for me. I have attached an unprotected version of the spreadsheet to this reply.

I'll give your solution for Q2 a try.

I'm glad you answered this post because I have noticed a small problem with the code you wrote for me (not that I'm not grateful ). I tried to solve it but I really don't know where to start. The code works fine until there are three risk sources or more (on the RiskSource spreadsheet) in a row that have a one-to-one relationship with the risk, i.e. a risk source only has one risk associated to it. When this occurs it seems to enter all the risks that are below the risk source. The attached spreadsheet has five risk sources of this sort in a row. If you could have a look at this for me it would be much appreciated.

Thanks

Lui

[mdmackillop]

Hi Lui,
I'll check it out tomorrow. Time for now.

[lui_roc]

thanks mate, enjoy!

[mdmackillop]

It might be simpler if RiskSource contained ID and Title in each row against the other data. Can this sheet be amended if necessary, so that I can code accordingly?

[lui_roc]

I don't see why not, might actually help the user to refer to source

[lui_roc]

Just a thought, made a few changes to the sheet. Don't know if they will effect but attached anyway?

[mdmackillop]

Hi Lui,
Here's a revised code section. It requires the SourceTitle to be inserted for each line in RiskSource as it searches for the first and last entries in column B
[vba]
Sub GetRisks(Target As Range)
ActiveSheet.Unprotect
On Error GoTo ars_exit:
Application.EnableEvents = False

Dim rFound As Range
Dim Rw As Long, i As Long
Dim lFound As Long
Set rFound = Sheets("RiskSource").Columns("B:B").Find(What:=Target, _
after:=[b1], LookIn:=xlFormulas, LookAt:=xlWhole)

Rw = Sheets("RiskSource").Columns("B:B").Find(What:=Target, _
after:=[b65536], SearchDirection:=xlPrevious, LookIn:=xlFormulas, _
LookAt:=xlWhole).Row

If Target = "Custom" Then
Target = InputBox("Enter risk source")
Rw = InputBox("Rows required")
Target.Offset(1).Range("A1:A" & Rw).EntireRow.Insert
Target.Offset(-1, 1).Range("A1:AC" & Rw + 1).FillDown
Target.Range("C1" & Rw).ClearContents
Target.Range("Q1:Q" & Rw).ClearContents
Else
Rw = Rw - rFound.Row + 1

Target.Offset(1).Range("A1:A" & Rw).EntireRow.Insert
Target.Offset(-1, 1).Range("A1:AH" & Rw + 1).FillDown
For i = 0 To Rw - 1
Target.Offset(i, 0) = rFound.Offset(i, 0)
Target.Offset(i, 2) = rFound.Offset(i, 2)
Target.Offset(i, 3) = rFound.Offset(i, 3)
Target.Offset(i, 4) = rFound.Offset(i, 1)
Target.Offset(i, 16) = rFound.Offset(i, 4)
Target.Range("F1:J" & Rw).ClearContents
Target.Range("M1:N" & Rw).ClearContents
Target.Range("R1:AD" & Rw).ClearContents
Target.Range("AG1:AG" & Rw).ClearContents
Next i
End If

ActiveSheet.Range("B7").Copy
ActiveSheet.Range("B7").PasteSpecial
ActiveSheet.Range("a7:a1000").Columns.AutoFit

Set LastUpdatedCell = Target
LastUpdatedTime = Now
Target.Select
ars_exit:
Application.EnableEvents = True

ActiveSheet.Range("B7").Copy
ActiveSheet.Range("B7").PasteSpecial
Set LastUpdatedCell = Target
LastUpdatedTime = Now
Target.Select


ActiveSheet.Protect

End Sub
[/vba]