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
Related
I have two Excel sheets in a workbook that I am wanting to copy data between and I can't figure it out. I am trying to adapt the code from a prior answer here but I can't get it to function how I want.
In short the two sheets are "Active" and "Term" for if an employee is active with the company or not. I am trying to get a pop-up when I run the macro to request entry of the employee ID. Once entered I want to find that unique ID in column A and then select a portion of the cells (cells A to G) in that row (of the unique value) then cut and paste it in the next empty row in the "term" sheet. Once that is done I want to delete the entire row from the active sheet.
I've used the match function nested within an index function to reference the unique value and return data from the sheets and others but I can't figure out if those will somehow help and how to implement them. What I am asking may not be possible. I can record a macro but the values are static and would only work that one exact time. Thank you in advance.
Sub EmployeeTermination()
Dim x As Long
Dim iCol As Integer
Dim MaxRowList As Long
Dim S As String
Dim fVal As String
Dim fRange As Range
Set wssource = Worksheets("Active")
Set wstarget = Worksheets("Term")
iCol = 1
MaxRowList = wssource.Cells(Rows.Count, iCol).End(xlUp).Row
For x = MaxRowList To 1 Step -1
S = wssource.Cells()
If S = "Yes" Or S = "yes" Then
fVal = InputBox(Enter employee ID:)
Set fRange = wstarget.Columns("A:A").Find(What:=fVal, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If fRange Is Nothing Then
AfterLastTarget = wstarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
wssource.Rows(x).Copy
wstarget.Rows(AfterLastTarget).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I know this basically rewrote your code, but I added a few checks to ensure you want to delete your employee. I made the assumption that the employee's name is in column B, so if not you can change this line:
If MsgBox("Are you sure you want to terminate " & wsActive.Cells(rngEmployee.Row, _
2) & "?", vbYesNo) Then
by replacing the 2 in the second row with whatever column number you would like. (or you can simply delete this check altogether).
I also added minimal error handling.
Option Explicit
Const Err_EmpNotFound = 1000
Public Function NextRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
NextRow = .Cells(.Rows.Count, col).End(xlUp).Row + 1
End With
End Function
Sub EmployeeTermination()
'On Error GoTo ErrHandler
Dim wsActive As Worksheet, wsTerm As Worksheet
Set wsActive = ThisWorkbook.Worksheets("Active")
Set wsTerm = ThisWorkbook.Worksheets("Term")
'Locate the employee
Dim rngEmployee As Range, sEmployeeID As String, empDataArr As Variant
sEmployeeID = Application.InputBox("Enter Employee ID")
Set rngEmployee = wsActive.Range("A:A").Find(sEmployeeID, Lookat:=xlWhole)
If rngEmployee Is Nothing Then
Err.Raise vbObjectError + Err_EmpNotFound, Description:="Employee Not Found"
End If
'Prompt before termination (assume's employee's name is column 2 (col B)
If MsgBox("Are you sure you want to terminate " & wsActive.Cells(rngEmployee.Row, _
2) & "?", vbYesNo) = vbNo Then
Exit Sub
End If
empDataArr = rngEmployee.Columns("A:G").Value
'Delete the data
rngEmployee.EntireRow.Delete
'Add employee to termination sheet (and date column "H")
With wsTerm.Rows(NextRow(wsTerm))
.Columns("A:G") = empDataArr
.Columns("H") = Date
End With
'Notify user of completion
MsgBox "Employee was successfully terminated!"
Exit Sub
ErrHandler:
Dim errBox As Long
Select Case Err.Number - vbObjectError
Case Err_EmpNotFound
errBox = MsgBox(Err.Description, vbRetryCancel)
If errBox = vbRetry Then
Err.Clear
EmployeeTermination
End
End If
Case Else
MsgBox Err.Description, Title:=Err.Number
End Select
End Sub
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
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.
I'm trying to create an advanced filter for the below table but the code below is just hiding the cells. It's working but my problem with it is if i filter something and then I drag to fill status or any other cells it will override the cells in between for example in filter mode I have 2 rows one is 1st row and the other one is at row 20 if I drag to fill status it will replace the status of all cells in between 1 and 20 and don't know how to work it out, i know this happens because I'm hiding the cells and not actually filtering them.
Any help will be much appreciated.
[Data Table][1]
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
r1 = Target.Row
c1 = Target.Column
If r1 <> 3 Then GoTo ending:
If ActiveSheet.Cells(1, c1) = "" Then GoTo ending:
Dim LC As Long
With ActiveSheet
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
End With
ActiveSheet.Range("4:10000").Select
Selection.EntireRow.Hidden = False
LR = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For r = 5 To LR
For c = 1 To LC
If ActiveSheet.Cells(2, c) = "" Or ActiveSheet.Cells(3, c) = "" Then GoTo nextc:
If ActiveSheet.Cells(2, c) = "exact" And UCase(ActiveSheet.Cells(r, c)) <> UCase(ActiveSheet.Cells(3, c)) Then ActiveSheet.Rows(r).EntireRow.Hidden = True: GoTo nextr:
If Cells(2, c) = "exact" Then GoTo nextc:
j = InStr(1, UCase(ActiveSheet.Cells(r, c)), UCase(ActiveSheet.Cells(3, c)))
If ActiveSheet.Cells(2, c) = "partial" And j = 0 Then ActiveSheet.Rows(r).EntireRow.Hidden = True: GoTo nextr:
nextc:
Next c
nextr:
Next r
ending:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The below code will be the answer to the question on how to create an advanced search based on multiple criteria on what the user selects in the table.
I will need a little bit of help with how to check if the user selected by mistake an empty cell I will need to make excel ignore filtering the blank cell. Also, I will need to make excel first to check if the yellow cells A3 to T3 has data in and if it has and i press the filter button will filter by the range A3:T3 and ignore the current user selection if there is no data in range A3:T3 will filter by the user selection and in the range A3:T3, if it has data will only filter by data cell that has data in them and ignore empty ones.
Sub advancedMultipleCriteriaFilter()
Dim cellRng As Range, tableObject As Range, subSelection As Range
Dim filterCriteria() As String, filterFields() As Integer
Dim i As Integer
If Selection.Rows.Count > 1 Then
MsgBox "Cannot apply filters to multiple rows within the same column. Please make another selection and try again.", vbInformation, "Selection Error!"
Exit Sub
End If
Application.ScreenUpdating = False
i = 1
ReDim filterCriteria(1 To Selection.Cells.Count) As String
ReDim filterFields(1 To Selection.Cells.Count) As Integer
Set tableObject = Selection.CurrentRegion
For Each subSelection In Selection.Areas
For Each cellRng In subSelection
filterCriteria(i) = cellRng.Text
filterFields(i) = cellRng.Column - tableObject.Cells(1, 1).Column + 1
i = i + 1
Next cellRng
Next subSelection
With tableObject
For i = 1 To UBound(filterCriteria)
.AutoFilter field:=filterFields(i), Criteria1:=filterCriteria(i)
Next i
End With
Set tableObject = Nothing
Application.ScreenUpdating = True
End Sub
Sub resetFilters()
Dim sht As Worksheet
Dim LastRow As Range
Application.ScreenUpdating = False
On Error Resume Next
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Range("A3:T3").ClearContents
Application.ScreenUpdating = True
Call GetLastRow
End Sub
Private Sub GetLastRow()
'Step 1: Declare Your Variables.
Dim LastRow As Long
'Step 2: Capture the last used row number.
LastRow = Cells(Rows.Count, 8).End(xlUp).Row
'Step 3: Select the next row down
Cells(LastRow, 8).Offset(1, 0).Select
End Sub
I'd like to make a summary sheet that, if changed, changes the source sheets it is pulling from. The code I have so far aggregates all of my sheets on the summary sheet on the summary sheet's activation event. I am trying to have all of my other sheets updated on the deactivation event but it does not seem to be working. Here is the code I am working with:
Private Sub Worksheet_Deactivate()
Application.ScreenUpdating = False
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 1 To UBound(tabs)
Sheets(tabs(j)).Select
Dim rng1 As Range
Dim Stri As String
For i = 3 To ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
Stri = ActiveSheet.Cells(i, "A")
Set rng1 = Worksheets("Summary").Range("A:A").Find(Stri, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets("Summary").Range(rng1.Address).EntireRow.Copy
ActiveSheet.Range("A" & i).EntireRow.Select
Selection.Insert Shift:=xlLeft
ActiveSheet.Range("A" & i + 1).EntireRow.Select
Selection.Delete Shift:=xlUp
Else
MsgBox strSearch & " not found"
End If
Next
ActiveSheet.Range("A" & 1).Select
Next
Application.ScreenUpdating = True
End Sub
I am very new to vba and this is my first post on stackoverflow so if I missed anything just let me know.
When you assign a variant array in that manner, you will end up with a zero-based array. You need to start at j = 0. As your own code currently is, it will never access the BELD worksheet.
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 0 To UBound(tabs)
....
A more universal method would be using For j = LBound(tabs) To UBound(tabs) which does not matter whether your array is 1 or 0 based as you let each array describe its own properties through the LBound function and UBound function.
A more comprehensive rewrite of your routine would include getting rid of the .Select and .Activate methods and use direct worksheet and cell referencing in its place.
Private Sub Worksheet_Deactivate()
Dim rng1 As Range
Dim Stri As String, lr As Long, j As Long, i As Long
Dim tabs As Variant
On Error GoTo bm_Safe_exit
Application.ScreenUpdating = False
Application.EnableEvents = False
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", _
"AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = LBound(tabs) To UBound(tabs)
With Sheets(tabs(j))
lr = .Cells.Find(Chr(42), After:=.Cells(1, 1), SearchDirection:=xlPrevious).Row
For i = 3 To lr
Stri = .Cells(i, "A").Value
If CBool(Len(Stri)) Then
On Error Resume Next
With Me.Range("A:A")
Set rng1 = .Find(What:=Stri, After:=.Cells(.Rows.Count), LookIn:=xlValues, LookAt:=xlWhole)
End With
On Error GoTo bm_Safe_exit
If Not rng1 Is Nothing Then
'clearing then copy/paste may be better than inserting, pasting and ultimately deleting old row
.Rows(i).Clear
rng1.EntireRow.Copy _
Destination:=.Range("A" & i)
Else
'maybe copy the data from the sheet back to the summary sheet if this occurs
MsgBox Stri & " on " & .Name & " not found on Summary"
End If
End If
Next
End With
Next
bm_Safe_exit:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Since this is in the Summary worksheet's code sheets, the use of Me can be applied to the Summary worksheet object. Once you have set rng1 to the range returned by the find, it is no longer necessary to describe the worksheet it comes from as its Range .Parent property is carried with it.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.