I'm having a problem with a macro because it give me Ambiguous name detected Worksheet_Change . If the user enter a value on any cell under column B it will run automatically a macro and if the user enter a value on column F it will run automatically another macro but I do not know how to fix this error . Please the the code below
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"))
If rng.Row > 2 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call MyMacro(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub MyMacro(rw As Long)
If Range("B" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("J" & rw & ":K" & rw) = Range("J" & rw & ":K" & rw).Value
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("F")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("F"))
If rng.Row > 3 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call Foolish(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub Foolish(rw As Long)
If Range("F" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("G" & rw & ":H" & rw) = Range("G" & rw & ":H" & rw).Value
End If
End Sub
You have two Worksheet_change() subs happening in your sheet. Copy the contents of one of those subroutines and paste it inside the other one so there is only one worksheet_change event.
For example:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"))
If rng.Row > 2 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call MyMacro(rng.Row)
End If
Next rng
End If
If Not Intersect(Target, Columns("F")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("F"))
If rng.Row > 3 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call Foolish(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub MyMacro(rw As Long)
If Range("B" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("J" & rw & ":K" & rw) = Range("J" & rw & ":K" & rw).Value
End If
End Sub
Related
I have a workbook that was previously working with no issues. Recently, however, I have been having a problem with adding/deleting columns on visible sheets after I run certain macros.
The workbook is used for groups of members. When data is imported into the file a base number of members are included. Throughout the use of the file the group can expand or contract. I have macros that will add new members or delete existing ones. These macros simply add data or remove it from specific data sheets. Another macro is used to refresh the keycells range that is used to adjust the columns on the visible sheets.
The issue I am having is that once I either add a new member or delete one, the code to increase or delete columns on the visible sheets does not work. The macro that refreshes the sheet doesn't work, nor does manually adjusting the cell itself.
If I do not import any data and simply add or delete columns from visible sheets (based on changing the keycells value), the code runs perfectly. It seems to only occur when I import data and try using macros that add or delete members. For example, without any data, I can add in 3 members and have new columns added in to each visible sheet. I can then reduce that number manually to 1 or 2 and have the appropriate number of columns deleted for each sheet. This works fine until data is imported and the other mentioned macros are used.
I also am experiencing an issue with the file where once I receive an error, even if I reset the VBA, I cannot continue working in it. I can maneuver throughout the file, however, adding or deleting columns (by any means) does not work. It's as though, even though the VBA was reset in the editor, the code does not exist.
This is the code that is used to refresh the keycell
Sub Refresh_ActivesheetB30()
Dim dwsNames As Variant: dwsNames = Array("DATA Member-19", "DATA Sch A-19", "DATA Sch A-3-19", "DATA Sch J-19", "DATA Sch R-19", "DATA 500U-19", "DATA 500U-P-19", "DATA 500U-PA-19")
frmWait.Show vbModeless
DoEvents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook: Set wb = ThisWorkbook
Dim gws As Worksheet: Set gws = wb.Worksheets("GroupInfo")
gws.Range("B30").Formula = "=COUNTIF('TAX INFO'!B34:B1499,"">0"")"
Dim dws As Worksheet
Dim dlRow As Long
Dim d As Long
For d = LBound(dwsNames) To UBound(dwsNames)
On Error Resume Next
Set dws = wb.Worksheets(dwsNames(d))
On Error GoTo 0
If Not dws Is Nothing Then
dlRow = dws.Range("D" & dws.Rows.Count).End(xlUp).Row
dws.Range("A12").Copy dws.Range("A12:A" & dlRow)
Set dws = Nothing
End If
Next d
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
gws.Activate
frmWait.Hide
End Sub
This code adds members
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim N As Long
Dim i As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Dim Rng5 As Range
Set ws = ActiveSheet
Set Rng1 = ws.Range("6:6").Find(Me.TextBox2.Value)
Set Rng2 = ws.Range("6:6").Find(Me.TextBox6.Value)
Set Rng3 = ws.Range("6:6").Find(Me.TextBox5.Value)
Set Rng4 = ws.Range("6:6").Find(Me.TextBox4.Value)
Set Rng5 = ws.Range("6:6").Find(Me.TextBox7.Value)
N = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox2, ws.Range("6:6"), TextBox2) = 0 And ComboBox1 <> 0 Then
MsgBox "Sorry, " & TextBox2 & " not found!"
Else
If TextBox3.Value = "" And ComboBox1.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox6, ws.Range("6:6"), TextBox6) = 0 And ComboBox2 <> 0 Then
MsgBox "Sorry, " & TextBox6 & " not found!"
Else
If TextBox8.Value = "" And ComboBox2.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox5, ws.Range("6:6"), TextBox5) = 0 And ComboBox3 <> 0 Then
MsgBox "Sorry, " & TextBox5 & " not found!"
Else
If TextBox9.Value = "" And ComboBox3.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox4, ws.Range("6:6"), TextBox4) = 0 And ComboBox4 <> 0 Then
MsgBox "Sorry, " & TextBox4 & " not found!"
Else
If TextBox10.Value = "" And ComboBox4.Value <> "" Then
MsgBox "There is no data to add", 48
Else
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox7, ws.Range("6:6"), TextBox7) = 0 And ComboBox5 <> 0 Then
MsgBox "Sorry, " & TextBox7 & " not found!"
Else
If TextBox11.Value = "" And ComboBox5.Value <> "" Then
MsgBox "There is no data to add", 48
Else
For i = 5 To N
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox1.Value Then
ActiveSheet.Cells(i, Rng1.Column).Value = frmAddAdj.TextBox3.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox2.Value Then
ActiveSheet.Cells(i, Rng2.Column).Value = frmAddAdj.TextBox8.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox3.Value Then
ActiveSheet.Cells(i, Rng3.Column).Value = frmAddAdj.TextBox9.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox4.Value Then
ActiveSheet.Cells(i, Rng4.Column).Value = frmAddAdj.TextBox10.Text
End If
If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox5.Value Then
ActiveSheet.Cells(i, Rng5.Column).Value = frmAddAdj.TextBox11.Text
End If
Next i
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End Sub
Private Sub CommandButton2_Click()
Unload frmAddAdj
End Sub
Private Sub CommandButton3_Click()
Dim ctl As MSForms.Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox", "ComboBox"
ctl.Text = ""
Case "CheckBox", "OptionButton", "ToggleButton"
ctl.Value = False
End Select
Next ctl
End Sub
Private Sub UserForm_Initialize()
Dim iRow As Integer, iMax As Integer
iRow = Cells.Find(What:="New Jersey Audit Adjustment", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
iMax = Cells.Find(What:="New Jersey Audit Adjustment", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False).Row
If ActiveSheet.Range("B" & iRow & ":B" & iMax).Cells.Count = 1 Then
Me.ComboBox1.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox2.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox3.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox4.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox5.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Else
Me.ComboBox1.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox2.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox3.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox4.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox5.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
End If
End Sub
This is the code to delete members
Private Sub CommandButton1_Click()
'declare the variables
Dim Findvalue As Range, DeleteRange As Range
Dim Response As VbMsgBoxResult
Dim cNum As Integer
Dim Search As String, FirstAddress As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("DATA Member-19")
'error statement
On Error Resume Next
Search = TextBox6.Value
'check for control from listbox dblclick values
If TextBox6.Value = "" Or Search = "" Then
MsgBox "There is not data to delete", 48
Exit Sub
Else
'find the employees number row
Set Findvalue = ws.Range("D:D").Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole)
If Not Findvalue Is Nothing Then
'mark first address
FirstAddress = Findvalue.Address
'give the user a chance to change their mind!
Response = MsgBox(Search & Chr(10) & _
"Are you sure that you want to delete this Member?", 292, "Are you sure?")
If Response = vbYes Then
'find all matching records
Do
If DeleteRange Is Nothing Then
Set DeleteRange = Findvalue
Else
Set DeleteRange = Union(DeleteRange, Findvalue)
End If
Set Findvalue = ws.Range("D:D").FindNext(Findvalue)
Loop While FirstAddress <> Findvalue.Address
'delete record(s)
DeleteRange.EntireRow.Delete
'clear the user form controls
cNum = 12
For x = 1 To cNum
Me.Controls("Reg" & x).Value = ""
Next
'Employee deleted from the database
MsgBox Search & Chr(10) & "The Member has been deleted successfully.", 64, "Record Deleted"
'add the values to the listbox
lstLookup.RowSource = ""
End If
Else
MsgBox Search & Chr(10) & "Record Not Found", 48, "Not Found"
End If
End If
End Sub
Private Sub CommandButton2_Click()
Unload frmDeleteMembers19
End Sub
This is the code that goes into the main sheet module
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, colNum As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
SOMESHEETS = "*C-Proposal-19*MemberInfo-19*Schedule J-19*NOL-19*NOL-P-19*NOL-PA-19*Schedule R-19*Schedule A-3-19*Schedule A-19*Schedule H-19*"
Set KeyCells = Range("B30")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
If IsNumeric(KeyCells.Value) Then
colNum = KeyCells.Value
If colNum > 0 Then
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
If CBool(InStr(LCase(SOMESHEETS), LCase("*" & ws.Name & "*"))) Then
InsertColumnsOnSheet argSheet:=ws, argColNum:=colNum
End If
End If
Next ws
End If
End If
End If
SOMESHEETS = "*MemberInfo-20*C-Proposal-20*Schedule J-20*NOL-20*Schedule R-20*NOL-P-20*SchA-3-20*Schedule H-20*NOL-PA-20*Schedule A-20*Schedule A-5-20*"
Set KeyCells = Range("B36")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
If IsNumeric(KeyCells.Value) Then
colNum = KeyCells.Value
If colNum > 0 Then
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
If CBool(InStr(LCase(SOMESHEETS), LCase("*" & ws.Name & "*"))) Then
InsertColumnsOnSheet argSheet:=ws, argColNum:=colNum
End If
End If
Next ws
End If
End If
End If
Application.ScreenUpdating = True
End Sub
And this is the general code that each sheet pulls from. I only included on sheet to save some space, but each sheet has similar code.
Public Sub InsertColumnsOnSheet(ByVal argSheet As Worksheet, ByVal argColNum As Long)
Dim Rng As Range, c As Range
Dim TotalCol As Long, LeftFixedCol As Long
Dim i As Long
Dim ws As Worksheet
Dim j As Integer, k As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set ws = Worksheets("C-Proposal-19")
With argSheet
Set Rng = .Range(.Cells(3, 6), .Cells(3, .Columns.Count))
Set c = Rng.Find("GROSS")
If Not c Is Nothing Then
TotalCol = c.Column
LeftFixedCol = 5
j = .Range("B4").End(xlToRight).Column
k = j - LeftFixedCol
If ws.Visible = xlSheetVisible Then
If TotalCol < LeftFixedCol + argColNum + 1 Then
.Columns(j).Copy
.Columns(j + 1).Resize(, argColNum - k).Insert CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
End If
End If
If TotalCol > LeftFixedCol + argColNum + 1 Then
For i = TotalCol - 1 To LeftFixedCol + argColNum + 1 Step -1
.Columns(i).Delete
Next i
End If
End If
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Moreover, if I add a member and refresh the keycells range, a new column will be added. If I then try to reduce the amount of columns manually, it will reduce the amount of columns. The issue pops up when I try use the delete macro. After I delete out the member through that macro, I cannot add or delete columns, either manually or through the refresh macro.
There also seems to be an issue where if I have an error pop up with VBA, the workbook does not use the code that I have in it. For example, if I change the general code to add/delete columns and I get an error, even if I reset the VBA in the editor, if I try and change the keycells nothing happens. I don't get the same error again, even though I don't change the code at all, and nothing happens to any of the sheets.
There is a bug in the first part of your code:
For d = LBound(dwsNames) To UBound(dwsNames)
On Error Resume Next
Set dws = wb.Worksheets(dwsNames(d))
On Error GoTo 0
If Not dws Is Nothing Then
dlRow = dws.Range("D" & dws.Rows.Count).End(xlUp).Row
dws.Range("A12").Copy dws.Range("A12:A" & dlRow)
Set dws = Nothing
End If
Next d
This shows the problem:
Dim ws As Worksheet, e
For Each e In Array("Sheet1", "Sheet2")
On Error Resume Next
Set ws = ThisWorkbook.Sheets(e)
On Error GoTo 0
If Not ws Is Nothing Then Debug.Print e, ws.Name
Next e
Run in a workbook which contains only Sheet1, it gives this output:
Sheet1 Sheet1
Sheet2 Sheet1 'oops!
So you need to add Set dws = Nothing before running Set dws = wb.Worksheets(dwsNames(d))
I´m trying to sort columns by value set in a drop down list.
I have got it to work for one column.
Value set in cell: B1
Sort Column A from A5 and hide cells not containing that value.
But I want to be able to sort multiple columns (A, B and C)via value in B1 and hide all rows not containing that specific value. See attatched image. Link:
https://i.stack.imgur.com/9NqC3.png
The working code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1")) Is Nothing Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Len(Range("B1").Value) > 0 Then Range("A5", Range("A" & Rows.Count).End(xlUp)).AutoFilter Field:=1, Criteria1:=Range("B1").Value
End If
End Sub
Please, try the next adapted code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, C As Range, rngDel As Range
If Target.Address = "$B$1" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Target.Value <> "" Then
lastR = Me.Range("A" & Rows.count).End(xlUp).row
With Me.Range("A5:C" & lastR)
.AutoFilter field:=1, Criteria1:=Target.Value
For Each C In Me.Range("B6:C" & lastR)
If C.Value = Target.Value Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Hidden = False
End With
End If
End If
End Sub
Edited:
The following code works when your last workbook structure. Please, try learning and understanding it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, C As Range, rngDel As Range
If Target.Address = "$E$1" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Target.Value <> "" Then
lastR = Me.Range("B" & Rows.Count).End(xlUp).Row
With Me.Range("G1:J" & lastR)
.AutoFilter field:=1, Criteria1:=Target.Value
For Each C In Me.Range("G2:J" & lastR)
If C.Value = Target.Value Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Hidden = False
End With
End If
End If
End Sub
You must use a complete filled column in order to calculate the last filled row!
The above code uses B:B column.
I have an Excel Macro below that I am using and it highlights the entire row yellow and the cell changed red when a change is made. It also is set up that if an additional cell is changed on the same row, the row stays yellow, the first changed cell stays red and the second cell changed is also turned red. The Macro works when you change a cell manually or copy and paste another cell.
The problem is that when I copy and paste more than one cell to a line, these highlighting features do not work. Does anyone know how I can modify the below Macro to also highlight the line yellow and make all cells copy and pasted red? I still would like the function that if I change another cell on the same line, it will keep all previously changed cells yellow and red on that line. Thanks in advance!
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Cl As Long ' last used column
With Target
If .CountLarge = 1 Then
' change .Row to longest used row number
' if your rows aren't of uniform length
If Sh.Cells(.Row, "A").Interior.Color <> vbYellow And _
Sh.Cells(.Row, "A").Interior.Color <> vbRed Then
Cl = Sh.Cells(.Row, Columns.Count).End(xlToLeft).Column
Sh.Range(Sh.Cells(.Row, 1), Sh.Cells(.Row, Cl)).Interior.Color = vbYellow
End If
.Interior.Color = vbRed
End If
End With
End Sub
Workbook_SheetChange (Whole Worksheets)
The following is easily tested:
Copy the code into the ThisWorkbook module of a new workbook.
Start entering, copy/pasting data on any worksheet and see what happens.
This one will not color yellow if to the right of the last yellow or red colored cell in the same row.
The Code
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' Initialize error handling.
Const ProcName As String = "Workbook_SheetChange"
On Error GoTo clearError
Const FirstCol As String = "A"
Dim tgt As Range
Set tgt = Target
Dim yRng As Range ' Yellow Range
Dim rRng As Range ' Red Range
Dim rng As Range ' Each Range in Areas
Dim cel As Range ' Each Cell in Range
Dim LastCol As Long ' Current Last Column
Dim CurRow As Long ' Current Row
'On Error GoTo clearError
Application.EnableEvents = False
For Each rng In tgt.Areas
For Each cel In rng.Cells
CurRow = cel.Row
If Sh.Cells(CurRow, FirstCol).Interior.Color <> vbRed Then
If Sh.Cells(CurRow, FirstCol).Interior.Color <> vbYellow _
Then
LastCol = Sh.Cells(CurRow, Columns.Count) _
.End(xlToLeft).Column
collectRanges yRng, _
Sh.Range(Sh.Cells(CurRow, FirstCol), _
Sh.Cells(CurRow, LastCol))
End If
collectRanges rRng, cel
End If
Next cel
Next rng
If Not yRng Is Nothing Then
yRng.Interior.Color = vbYellow
End If
If Not rRng Is Nothing Then
rRng.Interior.Color = vbRed
End If
SafeExit:
Application.EnableEvents = True
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0
GoTo SafeExit
ProcExit:
End Sub
Private Sub collectRanges(ByRef TotalRange As Range, _
AddRange As Range)
If Not TotalRange Is Nothing Then
Set TotalRange = Union(TotalRange, AddRange)
Else
Set TotalRange = AddRange
End If
End Sub
Sub toggleEE()
If Application.EnableEvents Then
Application.EnableEvents = False
Else
Application.EnableEvents = True
End If
End Sub
This one will not retain the previous red colors to the left.
The Code
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' Initialize error handling.
Const ProcName As String = "Workbook_SheetChange"
On Error GoTo clearError
Const FirstCol As String = "A"
Dim tgt As Range
Set tgt = Target
Dim yRng As Range ' Yellow Range
Dim rRng As Range ' Red Range
Dim rng As Range ' Each Range in Areas
Dim cel As Range ' Each Cell in Range
Dim LastCol As Long ' Current Last Column
Application.EnableEvents = False
With CreateObject("Scripting.Dictionary")
For Each rng In tgt.Areas
For Each cel In rng.Cells
If cel.Interior.Color <> vbRed Then
If cel.Interior.Color <> vbYellow Then
If Not .Exists(cel.Row) Then
.Add cel.Row, Empty
LastCol = Sh.Cells(cel.Row, Columns.Count) _
.End(xlToLeft).Column
collectRanges yRng, _
Sh.Range(Sh.Cells(cel.Row, FirstCol), _
Sh.Cells(cel.Row, LastCol))
End If
End If
collectRanges rRng, cel
End If
Next cel
Next rng
End With
If Not yRng Is Nothing Then
yRng.Interior.Color = vbYellow
End If
If Not rRng Is Nothing Then
rRng.Interior.Color = vbRed
End If
SafeExit:
Application.EnableEvents = True
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0
GoTo SafeExit
ProcExit:
End Sub
I have two Worksheet_Change event subs that work perfectly on their own, however I need to combine these to test the conditions of either of two ranges "G2" or G3". I have tried all the options in search, but just cannot get this to work. I would appreciate any assistance or advise.
Below are the two Subs:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G2")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("Z7:Z" & lr) = "=ISERROR(MATCH(G$2,B7:O7,0))"
Range("Z7", Range("Z" & Rows.Count).End(xlUp)).AutoFilter 1, False
Application.ScreenUpdating = True
Call activate_button_31
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G3")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("Q7:Q" & lr) = "=ISERROR(MATCH(G$3,B7:O7,0))"
Range("Q7", Range("Q" & Rows.Count).End(xlUp)).AutoFilter 1, False
Application.ScreenUpdating = True
Call activate_button_40
End Sub
Please let me know should you require any further information.
Kind Regards
Coenie
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).row
Application.ScreenUpdating = False
If Not Intersect(Target, Range("G2")) Is Nothing Then
Range("Z7:Z" & lr) = "=ISERROR(MATCH(G$2,B7:O7,0))"
Range("Z7", Range("Z" & Rows.Count).End(xlUp)).AutoFilter 1, False
Call activate_button_31
ElseIf Not Intersect(Target, Range("G3")) Is Nothing Then
Range("Q7:Q" & lr) = "=ISERROR(MATCH(G$3,B7:O7,0))"
Range("Q7", Range("Q" & Rows.Count).End(xlUp)).AutoFilter 1, False
Call activate_button_40
End If
Application.ScreenUpdating = True
End Sub
One way to combine the routines:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long
On Error GoTo Terminate
If Target.Count > 1 Then GoTo Terminate
xlQuiet True
lr = Range("B" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Range("G2")) Is Nothing Then
With Range("Z7:Z" & lr)
.Formula = "=ISERROR(MATCH(G$2,B7:O7,0))"
.AutoFilter 1, False
End With
xlQuiet False
Call activate_button_31
ElseIf Not Intersect(Target, Range("G3")) Is Nothing Then
With Range("Q7:Q" & lr)
.Formula = "=ISERROR(MATCH(G$3,B7:O7,0))"
.AutoFilter 1, False
End With
xlQuiet False
Call activate_button_40
End If
Terminate:
If err Then
Debug.Print "Error", err.Number, err.Description
err.clear
End If
xlQuiet False
End Sub
Private Sub xlQuiet(Optional ByVal b As Boolean)
With Application
.ScreenUpdating = Not b
.EnableEvents = Not b
End With
End Sub
I need to compare values on two separate sheets, both are in column H starting at 2. One sheet is labeled final, the other data. If it is in final and not in data then highlight in final. If something found in data is not in final copy it into final (whole row) at the bottom. It is all text. Column H is titled "Reference".
code 1
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column <> 8 Then Exit Sub
Dim lastRow As Long
Dim rng As Range, cell As Range
lastRow = Range("H" & Rows.Count).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set rng = Range("H2:H" & lastRow)
For Each cell In rng
With Sheets("data")
a = Application.VLookup(cell.Value, .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row), 1, 0)
If IsError(a) Then
cell.Interior.Color = vbYellow
Else
cell.Interior.Color = xlNone
End If
End With
Next
Application.EnableEvents = True
End Sub
code 2
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column <> 8 Then Exit Sub
Dim lastRow As Long
Dim rng As Range, cell As Range
lastRow = Range("H" & Rows.Count).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set rng = Range("H2:H" & lastRow)
For Each cell In rng
With Sheets("final")
a = Application.VLookup(cell.Value, .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row), 1, 0)
If IsError(a) Then
cell.Copy .Range("H" & .Range("H" & Rows.Count).End(xlUp).Row)
End If
End With
Next
Application.EnableEvents = True
End Sub