Create a AllowEditRange conditional to a value on a column range - vba

I have the code below which allow me to unprotect a sheet with an AllowEditRange, verify which rows of a range in column C has data on it and write the work "Ok" on column B in the rows where data was found in column C. The code also protects the sheet in the end returning to normal with my AllowEditRange but I need that the rows where the "Ok" was stamped are taken out of the AllowEditRange, blocking them for further edition. In other words I'm looking for a way to cancel these rows from the AllowEditRange or delete the range and create a new one excluding the rows with "Ok" in column B.
I'm trying to incorporate something like:
Dim aer As AllowEditRange
For Each aer In ActiveSheet.Protection.AllowEditRanges
aer.Delete
If InStr(-1, cell.Value, "") <> 0 Then
Set aer = workbook.Protection.AllowEditRanges.Add("Edition", workbook.Range("A1:D4"))
aer.Users.Add "Power Users", True
End If
But it's not working no matter what I do. Any help?
Sub Test()
ActiveSheet.Unprotect Password:="Maze"
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
Application.ScreenUpdating = False
Dim lastRow As Long
Dim cell As Range
lastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each cell In Range("C32:C70" & lastRow)
If InStr(1, cell.Value, "") <> 0 Then
cell.Offset(, -1).Value = "Ok"
End If
Next
Application.ScreenUpdating = True
ActiveSheet.Protect Password:="Maze"
End Sub

As it was giving me a huge headache and consuming loads of time, I gave up of the AllowEditRanges and came up with a a work around. I just split the code in two and used the good old lock and unlock cells. I'm leaving the code below if anybody got decides to go for it too. Also, the code I came up with is very slow and after a couple of hours I decided to ask if anybody has a faster alternative.
Sub LockRow()
Dim rChk As Range, r1st As Range
Set r1st = Columns("B").Find(What:="Ok", _
after:=Cells(Rows.Count, "B"), _
LookIn:=xlValues, lookat:=xlPart, _
searchdirection:=xlNext)
If Not r1st Is Nothing Then
Set rChk = r1st
Do
ActiveSheet.Unprotect Password:="Maze"
rChk.EntireRow.Locked = True
ActiveSheet.Protect Password:="Maze"
Set rChk = Columns("B").FindNext(after:=rChk)
Loop While rChk.Address <> r1st.Address
End If
Set r1st = Nothing
Set rChk = Nothing
End Sub

Related

VBA: Command button updating Excel sheet based on Listbox contents

If a name appears in Listbox2, i need to search a sheet with any matching names and update column 9 from 0 to 1. Currently, the code i have nearly works, but does not account for names that appear more than 1 time in the sheet. So only the first time a name appears in the sheet, does column 9 update from 0 to 1.
Below is the code im using:
Private Sub CommandButton6_Click()
ThisWorkbook.RefreshAll
Dim i As Integer
Dim wks As Worksheet
Set wks = Sheet1
For i = 0 To ListBox2.ListCount - 1
ListBox2.Selected(i) = True
rw = wks.Cells.Find(What:=Me.ListBox2.List(i), SearchOrder:=xlRows,
SearchDirection:=xlNext, LookIn:=xlValues, lookat:=xlWhole).Row
wks.Cells(rw, 9).Value = "1"
Next i
Sheet3.Shapes("Button 3").Visible = Sheet1.Cells(1, 26) > "0"
MsgBox ("Update Successful")
Me.Hide
ListBox2.Clear
ThisWorkbook.RefreshAll
End Sub
Thank you for any help
You can use Find in this way to look for something which occurs more than once. You store the address of the first found cell, and then loop until you return to this cell which tells you that you've found all instances. When using Find it's also worth checking first that your value is found - your code would error if the term were not found.
Private Sub CommandButton6_Click()
ThisWorkbook.RefreshAll
Dim i As Long
Dim wks As Worksheet, r As Range, s As String
Set wks = Sheet1
For i = 0 To ListBox2.ListCount - 1
ListBox2.Selected(i) = True
Set r = wks.Cells.Find(What:=Me.ListBox2.List(i), SearchOrder:=xlRows, _
SearchDirection:=xlNext, LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then
s = r.Address
Do
wks.Cells(r.Row, 9).Value = 1
Set r = wks.Cells.FindNext(r)
Loop Until r.Address = s
End If
Next i
Sheet3.Shapes("Button 3").Visible = Sheet1.Cells(1, 26) > "0"
MsgBox ("Update Successful")
Me.Hide
ListBox2.Clear
ThisWorkbook.RefreshAll
End Sub

Conflict between Modules Excel VBA

The two modules below always run in a loop.
I want the second module for verification that a record was created after the first module runs, since all the user sees is the question, but not the result.
First module detects when new row is added to a table and asks if you want to export data to another worksheet:
Sub NewDatabaseEntry()
Dim sh As Worksheet
Dim rspn As VbMsgBoxResult
rspn = MsgBox("Do you want to create a project? If you did not add a new row, click No", vbYesNo)
If rspn = vbNo Then Exit Sub
Range("MasterTemplate").Copy
Sheets("Database").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteFormulas
FindProjectName 'A macro that literally finds the name of the project...
'FindRow
End Sub
This module then looks at the row number on the destination worksheet and then copies that row number value to a predefined range.
Sub FindRow()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("Projects").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundRng As Range
For Each rng In Sheets("Projects").Range("B2:B" & LastRow)
Set foundRng = Sheets("Database").Range("C:C").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If Not foundRng Is Nothing Then
rng.Offset(0, -1) = foundRng.Row
End If
Next rng
Application.ScreenUpdating = True
End Sub
The only way FindRow works is when I place it in the ThisWorkbook~ Excel Object.
If I place it anywhere else, it gets into a loop with the NewDatabaseEntry module where it keeps asking you if youwant to create a new project.`
I would've liked for the user to know that the entry was created without having to close out of the workbook and then reopening it, just to verify what row number their record was placed on.
Is there something I am missing?
Since you mention that this gets stuck in an infinite loop to ask if they want to create a new project, I believe that the reason is because you have a Worksheet_Change event (or similar) that fires off when you add a value to the Projects worksheet.
The problem comes in when you have your FindProject manipulating data on the same worksheet that your Worksheet_Change event is looking for.
So what I believe you should do is turn off events until FindProject is done (by the way, I would recommend changing FindProject to something else because it does more than just "find a project").
Sub FindRow()
Application.ScreenUpdating = False
Application.EnableEvents = False ' ADDED THIS
Dim LastRow As Long
LastRow = Sheets("Projects").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundRng As Range
For Each rng In Sheets("Projects").Range("B2:B" & LastRow)
Set foundRng = Sheets("Database").Range("C:C").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If Not foundRng Is Nothing Then
rng.Offset(0, -1) = foundRng.Row
End If
Next rng
Application.EnableEvents = True ' ADDED THIS
Application.ScreenUpdating = True
End Sub

VBA - Find all matches across multiple sheets

I am working on a macro that will search an entire workbook for various codes. These codes are all six digit numbers. Codes I wish to search for are input in column A of a sheet called "Master". If a code found on another sheet matches one in Master it's sheet name and cell will be pasted in column B next to it's match in Master. When successful the end result looks like this.
The code posted below works in certain cases, but fails quite often. Occasionally a run-time error will appear, or an error message with "400" and nothing else. When these errors occur the macro fills a row with matches for a blank value at the end of all the listed codes. This is obviously not an intended function.
I am at a loss regarding the above error. I have wondered if limiting the search range would help stability. All codes on other sheets are only found in column A, so searching for matches in all columns as is done currently is quite wasteful. Speed is secondary to stability however, I first want to eliminate all points of failure.
Sub MasterFill()
Dim rngCell As Range
Dim rngCellLoc As Range
Dim ws As Worksheet
Dim lngLstRow As Long
Dim lngLstCol As Long
Dim strSearch As String
Sheets("Master").Select
lngLstRowLoc = Sheets("Master").UsedRange.Rows.Count
Application.ScreenUpdating = False
For Each rngCellLoc In Range("A1:A" & lngLstRowLoc)
i = 1
For Each ws In Worksheets
If ws.Name = "Master" Then GoTo SkipMe
lngLstRow = ws.UsedRange.Rows.Count
lngLstCol = ws.UsedRange.Columns.Count
ws.Select
For Each rngCell In Range(Cells(2, 1), Cells(lngLstRow, lngLstCol))
If InStr(rngCell.Value, rngCellLoc) > 0 Then
If rngCellLoc.Offset(0, i).Value = "" Then
rngCellLoc.Offset(0, i).Value = ws.Name & " " & rngCell.Address
i = i + 1
End If
End If
Next
SkipMe:
Next ws
Next
Application.ScreenUpdating = True
Worksheets("Master").Activate
MsgBox "All done!"
End Sub
See if this doesn't expedite matters while correcting the logic.
Sub MasterFill()
Dim addr As String, fndCell As Range
Dim rngCellLoc As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
With Worksheets("Master")
For Each rngCellLoc In .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
For Each ws In Worksheets
If LCase(ws.Name) <> "master" Then
With ws.Columns("A")
Set fndCell = .Find(what:=rngCellLoc.Value2, After:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Not fndCell Is Nothing Then
addr = fndCell.Address(0, 0)
Do
With rngCellLoc
.Cells(1, .Parent.Columns.Count).End(xlToLeft).Offset(0, 1) = _
Join(Array(ws.Name, fndCell.Address(0, 0)), Chr(32))
End With
Set fndCell = .FindNext(After:=fndCell)
Loop While addr <> fndCell.Address(0, 0)
End If
End With
End If
Next ws
Next
.Activate
End With
Application.ScreenUpdating = True
MsgBox "All done!"
End Sub
I've used LookAt:=xlPart in keeping with your use of InStr for criteria logic; if you are only interested in whole cell values change this to LookAt:=xlWhole.
I've restricted the search range to column A in each worksheet.
Previous results are not cleared before adding new results.
Your own error was due to the behavior where a zero length string (blank or vbNullString) is found within any other string when determined by Instr.

search a worksheet for all value VBA Excel

I have a worksheet that has multiple value and what I would like to do is search say column "B" for a value and when it finds it to copy the complete row and paste it somewhere else. I have a similar function to do this but it stops after it finds the first one which is fine for the situation that I am using it in but for this case I need it to copy all that match. below is the code that im using at the moment that only gives me one value
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.value
lastRow = wks1.range("A" & Rows.Count).End(xlUp).row
Set rangeList = wks1.range("A2:A" & lastRow)
On Error Resume Next
row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
Thanks
I would suggest to load data into array first and then operate on this array instead of operating on cells and using Worksheet functions.
'(...)
Dim data As Variant
Dim i As Long
'(...)
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.Value
lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row
'Load data to array instead of operating on worksheet cells directly - it will improve performance.
data = wks1.Range("A2:A" & lastRow)
'Iterate through all the values loaded in this array ...
For i = LBound(data, 1) To UBound(data, 1)
'... and check if they are equal to string [strSelect].
If data(i, 1) = strSelect Then
'Row i is match, put the code here to copy it to the new destination.
End If
Next i
End If
I have used the Range.Find() method to search each row. For each row of data which it finds, where the value you enter matches the value in column G, it will copy this data to Sheet2. You will need to amend the Sheet variable names.
Option Explicit
Sub copyAll()
Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook
Dim strSelect As String, firstFind As String
Set wb = ThisWorkbook
Set findSheet = wb.Sheets("Sheet1")
Set destSheet = wb.Sheets("Sheet2")
strSelect = ExpIDComboBox.Value
Application.ScreenUpdating = False
With findSheet
Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues)
If Not rngFound Is Nothing Then
firstFind = rngFound.Address
Do
.Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _
.Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address))
Loop While firstFind <> rngFound.Address
End If
End With
Application.ScreenUpdating = True
End Sub
I've assumed you will have data between columns A:G?
Otherwise you can just amend the .Copy and .PasteSpecial methods to fit your requirements.
Thanks for your replys. I tired to use both methods but for some reason they did not seem to work. They did not give me an error they just did not produce anything.#mielk I understand what you mean about using an array to do this and it will be a lot faster and more efficent but I dont have enfough VBA knowledge to debug as to why it did not work. I tried other methods and finally got it working and thought it might be usefull in the future for anybody else trying to get this to work. Thanks once again for your answers :)
Private Sub SearchButton2_Click()
Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long
Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions
If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected
selectedString = DomainComboBox.value
lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row
Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search
i = 2
'used to only create a new sheet is something is found
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
For Each ws In Sheets
Application.DisplayAlerts = False
If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results
Next
Application.DisplayAlerts = True
Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets
ws.Name = "Search Results" 'renames the worksheet to search results
wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page
ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page
For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected
If domainRange.value = selectedString Then
wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in
emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row
ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents
End If
i = i + 1 'moves onto the next row
ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell
ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour
Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting
Next domainRange ' goes to next value
Else
MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found
Exit Sub
End If
End If
End Sub
Thanks.
N.B. this is not the most efficent way of doing this read mielk's answer and the other answer as they are better if you can get them working.

Excel VBA For Loop Error

I'm trying to run a simple For loop which will be expanded to include more functionality later but having trouble as it keeps throwing an error "invalid next control variable reference". The code I am trying to use is listed below.
Sub Tickbox()
Set Location = Sheets("TickBoxSheet").Range("B:B")
i = WorksheetFunction.CountA(Location)
Sheets("TickBoxSheet").Range("B2").Select
For a = 1 To i
If Selection.Value = "True" Then
Row = Selection.Row
'Hide some rows in another sheet via if statements
ActiveCell.Offset(1, 0).Select
End If
Next i
End Sub
I don't know if I need more coffee this morning but I can't seem to figure out what the hell is going on. Any help will be greatly appreciated.
The incremented variable (in Next) should be the index variable, i.e.:
For a = 1 To i
'...
Next a
i is so popular as index that you should think twice before using it in other contexts.
You have already got your answer from llmo. However there are few other things I would like to stress upon...
Try and avoid .Select. It will slow down your code.
Also It is not necessary that WorksheetFunction.CountA(Location) will give you the last row considering that you want to loop through all the rows which have data. I suggest this
Sub Tickbox()
Dim i As Long, a As Long, Rw As Long
With Sheets("TickBoxSheet")
i = .Range("B" & .Rows.Count).End(xlUp).row
For a = 2 To i
If .Range("B" & a).Value = "True" Then
Rw = a
'Hide some rows in another sheet via if statements
End If
Next a
End With
End Sub
You can make it more fast using Autofilter as well so that you loop through cells which only have True For example
Sub Tickbox()
Dim i As Long, a As Long, Rw As Long
Dim Location As Range, acell As Range
With Sheets("TickBoxSheet")
'~~> Remove any filters
.AutoFilterMode = False
i = .Range("B" & .Rows.Count).End(xlUp).row
With .Range("B1:B" & i)
.AutoFilter Field:=1, Criteria1:="True"
Set Location = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
Debug.Print Location.Address
End With
'~~> Remove any filters
.AutoFilterMode = False
For Each acell In Location
If acell.Value = "TRUE" Then
Rw = acell.row
'Hide some rows in another sheet via if statements
End If
Next acell
End With
End Sub