Reset/Reuse Target Range for Spreadsheet - vba

I am attempting to write a macro that will send an email if a specific range is selected and meets certain criteria. I have several email subs that will be called depending upon which range is selected/activated. I'm trying to use the Intersect(Range, Target) method to restrict which range will call which email sub. The problem I'm having is that my code always defaults to the first range in the sheet, but I need it to just use the active range. I've included a sample of my code below.
Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
'Checklist Setup Review
Dim LastRow As Long
Dim i As Long
Dim xRg As Range
Dim x As String
Dim NewRng As Range
LastRow = Cells(Rows.Count, "H").End(xlUp).Row
For i = 1 To LastRow
If UCase(Cells(i, "H").Value) = "P" Then
If NewRng Is Nothing Then
Set NewRng = Cells(i, "A")
Else
Set NewRng = Union(NewRng, Cells(i, "A"))
End If
End If
Next i
'Initial Lidar Review
Dim LastRow1 As Long
Dim e As Long
Dim NewRng1 As Range
LastRow1 = Cells(Rows.Count, "I").End(xlUp).Row
For e = 1 To LastRow1
If UCase(Cells(e, "I").Value) = "P" Then
If NewRng1 Is Nothing Then
Set NewRng1 = Cells(e, "A")
Else
Set NewRng1 = Union(NewRng1, Cells(e, "A"))
End If
End If
Next e
'Initial Ground Macro Review
Dim LastRow2 As Long
Dim xRg2 As Range
Dim j As Long
Dim NewRng2 As Range
LastRow2 = Cells(Rows.Count, "J").End(xlUp).Row
For j = 1 To LastRow2
If UCase(Cells(j, "J").Value) = "P" Then
If NewRng2 Is Nothing Then
Set NewRng2 = Cells(j, "A")
Else
Set NewRng2 = Union(NewRng2, Cells(j, "A"))
End If
End If
Next j
'Call Email subs
If xRg Is Nothing Then
Set xRg = Intersect(NewRng, Target)
x = True
For Each r In NewRng
If r.Value <> "Pass" And r.Value <> "Complete" Then
x = False
End If
Next r
If x = True Then
MsgBox "Project Setup Review Complete: Auto Email Sent."
Call SetupReview_Email
End If
ElseIf xRg Is Nothing Then
Set xRg = Intersect(NewRng1, Target)
If xRg Is Nothing Then Exit Sub
x = True
For Each r In NewRng1
If r.Value <> "Pass" And r.Value <> "Complete" Then
x = False
End If
Next r
If x = True Then
MsgBox "Intial Lidar Review Completed: Auto Email Sent."
InitialLidarReview_Email
End If
ElseIf xRg Is Nothing Then
Set xRg = Intersect(NewRng2, Target)
For Each r In NewRng2
If r.Value <> "Pass" And r.Value <> "Complete" Then
x = False
End If
Next r
If x = True Then
MsgBox "Ground Macro Review Completed: Auto Email Sent."
Call GroundMacro_Email
End If
End If
End Sub

Doing this slightly rushed but hopefully you get the gist. Should the If statements actually be checking if the Intersect is NOT Nothing?
Set xRg = Intersect(NewRng, Target)
If xRg Is Nothing Then
'stuff
Else
Set xRg = Intersect(NewRng1, Target)
If xRg Is Nothing Then
'stuff
Else
Set xRg = Intersect(NewRng2, Target)
If xRg Is Nothing Then
'stuff
End If
End If
End If

Related

Select the same range in multiple workheets

So I need to select the same range in all worksheets except "Sheet1". The range is dinamic based on the value "s1" on the column A. So I want to select what is in column B for the value s1, make it bold, then to count the s1 values in column C.
This is what I have so far
Sub test()
Dim ws As Worksheet
Dim lastrow As Long
Dim xRg As Range, yRg As Range, zRg As Range
Dim cell As Range
Dim C1 As Range
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For Each xRg In Range("A1:A" & lastrow)
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = Range("B" & xRg.Row).Resize(, 1)
k = 1
For Each cell In yRg
yRg.Cells(k, 2) = k
yRg.Cells.Select
k = k + 1
Next cell
Else
Set yRg = Union(yRg, Range("B" & xRg.Row).Resize(, 1))
If Not yRg Is Nothing Then yRg.Select
For Each C1 In yRg
C1.EntireRow.Font.Bold = True
Next C1
End Sub
Try this code:
Option Explicit
Sub test()
Dim ws As Worksheet
Dim xRg As Range, yRg As Range
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
ws.Cells.Font.Bold = False ' clear bold formatting for debugging purposes
Set yRg = Nothing
For Each xRg In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = xRg.Offset(0, 1)
Else
Set yRg = Union(yRg, xRg.Offset(0, 1))
End If
xRg.Offset(0, 2) = yRg.Cells.Count 'set entry number
End If
Next xRg
If Not yRg Is Nothing Then yRg.Font.Bold = True
End If
Next ws
Application.ScreenUpdating = True
End Sub
Before
After
A selection or a range does not extend across multiple sheets; there is a selection per sheet. So you need to work within each sheet.
You had a lot of unclosed loops and conditions. This is my best guess at what you were trying to do:
Sub test()
Dim ws As Worksheet
Dim lastrow As Long
Dim xRg As Range, yRg As Range
Dim cell As Range
Dim s1count As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
Set yRg = Nothing
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For Each xRg In Range("A1:A" & lastrow)
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = xRg.Offset(0, 1)
Else
Set yRg = Union(yRg, xRg.Offset(0, 1))
End If
End If
Next xRg
If Not yRg Is Nothing Then
s1count = 0
For Each cell In yRg
cell.EntireRow.Font.Bold = True
s1count = s1count + 1
cell.Offset(0, 1) = s1count
Next cell
End If
End If
Next ws
End Sub

Loop through the range and then sheets and delete rows based on cell value

I'm working on a loop that will feed of a cell in sheet "Results" and go through number of worksheets (at the moment set to 1-3) and delete the row where it finds the value from sheet "Results". At the moment it fails, can you please advise?
Sub Del_Rows()
Dim rng As Range, cell As Range, del As Range
Dim sht As Worksheet
For x = 1 To 3
Set sht = Sheets(x)
Set del = Sheets("Results").Range("A13")
Set rng = Intersect(sht.Range("A1:A2000"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) = Sheets("Results").Range("A13") Then
If del Is Nothing Then
Set del = cell
Else
Set del = Union(del, cell)
End If
End If
Next cell
If del Is del Then del.EntireRow.Delete
Next x
End Sub
Also, I understand it might be a lot trickier to do but is it possible for the code to have a look at the dynamic range in sheet("Results") one by one?
What I mean is e.g. the code takes the value of Sheets("Results").Range("A13") and does the search for the value across the sheets 1-3 deleting rows when it finds it, and then it moves to Sheets("Results").Range("A14") and does the same thing.
Since the data in [Sheets("Results").Range("A13") + last row] is dynamic it simply does the same thing until it reaches the end (e.g. Sheets("Results").Range("A20").
Thanks a lot
I didn't test the code, so maybe there's some syntax error or typo.
Dim wb as workbook
Set wb = ActiveWorkbook
set rsws = wb.worksheets("Results")
dim lastResult as Long
lastResult = rsws.Usedrange.SpecialCells(xlCelltypeLastcell).Row 'count the last row of ResultSheet.
dim lastrowCheck as Long
for each ws in wb.worksheets 'loop through each worksheet
lastrowCheck = ws.Usedrange.SpecialCells(xlCelltypeLastcell).Row
if ws.name <> "Results" then
for i = 1 to lastResult 'loop through each Result range cell
for j = 1 to lastrowCheck 'loop throught and check value
if rsws.cells(i,13) <> vbNullString then
if rsws.cells(i,13) = ws.cells(j,1) then 'I suppose that it's in the first column.
'your deleting code here
end if
end if
next j
next i
end if
next ws
Below is the actual code in my excel which includes some debug print.
Sub testtesttest()
Dim wb As Workbook
Set wb = ActiveWorkbook
Set rsws = wb.Worksheets("Results")
Dim lastResult As Long
lastResult = rsws.UsedRange.SpecialCells(xlCellTypeLastCell).Row 'count the last row of ResultSheet.
Dim lastrowCheck As Long
For Each ws In wb.Worksheets 'loop through each worksheet
lastrowCheck = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Debug.Print "lastrowCheck "; lastrowCheck
Debug.Print ws.name
If ws.name <> "Results" Then
For i = 1 To lastResult 'loop through each Result range cell
For j = 1 To lastrowCheck 'loop throught and check value
If rsws.Cells(i, 13) = ws.Cells(j, 1) Then 'I suppose that it's in the first column.
'your deleting code here
Debug.Print "good good good"
End If
Next j
Next i
End If
Next ws
End Sub
I have managed to work on my initial code and came up with the following solution, which works for me.
Public Sub Loop_DEL()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------------------------------------------
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'----------------------------------------------------------------------
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range, rng8 As Range, c As Range
Dim rngToDel2 As Range, rngToDel3 As Range, rngToDel4 As Range, rngToDel5 As Range, rngToDel6 As Range, rngToDel7 As Range, rngToDel8 As Range
Dim lastRow As Long
With Worksheets("Results")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng1 = .Range("A3:A" & lastRow)
End With
Set rng2 = Worksheets("ANY SCORE").Range("A:A")
Set rng3 = Worksheets("Page1").Range("A:A")
Set rng4 = Worksheets("Page2").Range("A:A")
Set rng5 = Worksheets("Page3").Range("A:A")
Set rng6 = Worksheets("Page4").Range("A:A")
Set rng7 = Worksheets("Page5").Range("A:A")
Set rng8 = Worksheets("Page6").Range("A:A")
For Each c In rng2
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel2 Is Nothing Then
Set rngToDel2 = c
Else
Set rngToDel2 = Union(rngToDel2, c)
End If
End If
Next c
If Not rngToDel2 Is Nothing Then rngToDel2.EntireRow.Delete
For Each c In rng3
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel3 Is Nothing Then
Set rngToDel3 = c
Else
Set rngToDel3 = Union(rngToDel3, c)
End If
End If
Next c
If Not rngToDel3 Is Nothing Then rngToDel3.EntireRow.Delete
For Each c In rng4
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel4 Is Nothing Then
Set rngToDel4 = c
Else
Set rngToDel4 = Union(rngToDel4, c)
End If
End If
Next c
If Not rngToDel4 Is Nothing Then rngToDel4.EntireRow.Delete
For Each c In rng5
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel5 Is Nothing Then
Set rngToDel5 = c
Else
Set rngToDel5 = Union(rngToDel5, c)
End If
End If
Next c
If Not rngToDel5 Is Nothing Then rngToDel5.EntireRow.Delete
For Each c In rng6
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel6 Is Nothing Then
Set rngToDel6 = c
Else
Set rngToDel6 = Union(rngToDel6, c)
End If
End If
Next c
If Not rngToDel6 Is Nothing Then rngToDel6.EntireRow.Delete
For Each c In rng7
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel7 Is Nothing Then
Set rngToDel7 = c
Else
Set rngToDel7 = Union(rngToDel7, c)
End If
End If
Next c
If Not rngToDel7 Is Nothing Then rngToDel7.EntireRow.Delete
For Each c In rng8
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel8 Is Nothing Then
Set rngToDel8 = c
Else
Set rngToDel8 = Union(rngToDel8, c)
End If
End If
Next c
If Not rngToDel8 Is Nothing Then rngToDel8.EntireRow.Delete
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

VBA to 'print' matched search results to new WS

I have some coding which loops through a list of policy numbers, and then searches through an entire workbook for a matching policy number, bolding any matches found in the original list. The coding works fine, however what I would like to do if possible, is to 'print' the address/cell location of the matching value. For example, if policy number 1 was located on sheet 3, cell a1, then this would be displayed on a new blank worksheet. I'm sure this can be done using dictionaries and the print.debug function, But I want to avoid using a dictionary if possible. Hope this makes sense!
Sub HighlightMatches()
Application.ScreenUpdating = True
Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long,bln As Boolean
iRowL = Sheets(3).Cells(Rows.Count, "P").End(xlUp).row
For iRow = 1 To iRowL
If Not IsEmpty(Cells(iRow, 16)) Then
For iSheet = ActiveSheet.Index + 1 To Worksheets.Count
bln = False
var = Application.match(Cells(iRow, 16).Value, Worksheets(iSheet).Columns(16), 0)
If Not IsError(var) Then
bln = True
Exit For
End If
Next iSheet
End If
' The below would 'print' all matches and an offset value to a new Worksheet.
If bln = False Then
Cells(iRow, 16).Font.Bold = False
Else
Cells(iRow, 16).Font.Bold = True
End If
Next iRow
Application.ScreenUpdating = True
End Sub
This would do it:
Option Explicit
Sub HighlightMatches()
Dim OriginalWS As Worksheet, NewListWorksheet As Worksheet, ws As Worksheet
Dim Cel As Range, Rng As Range, rSearchCell As Range
Set OriginalWS = ActiveSheet
Set Rng = Columns("P:P").SpecialCells(xlCellTypeConstants, 23)
For Each Cel In Rng
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> OriginalWS.Name And ws.Name <> "Search List" Then
On Error Resume Next
Set rSearchCell = ws.Columns("P:P").Find(What:=Cel.Value, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
On Error GoTo 0
If Not rSearchCell Is Nothing Then
Cel.Font.Bold = True
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Search List"
On Error Resume Next
Set NewListWorksheet = ActiveSheet
On Error GoTo 0
If Not NewListWorksheet Is Nothing Then
NewListWorksheet.Range("A" & NewListWorksheet.Range("A" & NewListWorksheet.Rows.Count).End(xlUp).Row + 1).Value = Cel.Value
Else
Set NewListWorksheet = Sheets.Add.Name = "Search List"
NewListWorksheet.Range("A1").Value = "Search results"
NewListWorksheet.Range("A1").Font.Bold = True
NewListWorksheet.Range("A2").Value = Cel.Value
End If
Else
Cel.Font.Bold = False
End If
End If
Set rSearchCell = Nothing 'Clear Cel
Next
Next
End Sub

Need this to work with a button press

I found this code on this site that works for what I'm trying to do with a sign out log with one exception - it works as a worksheet update function right now and I need it to only work when a button is pressed. How would I modify this code so that it can be a macro that would be assigned to a button? Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
Application.EnableEvents = True End Sub
If you want to keep checking for values in column A only, then
Sub clickMe()
Dim A As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Selection)
If Inte Is Nothing Then Exit Sub
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
End Sub
If the column does not matter and the button should enter a date to the right of the selected cell, then
Sub clickMe()
Dim r As Range
For Each r In Selection
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
End Sub

VBA Excel "Object Required" error

My codes gives me a Object Required 424 error on this line:
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
My full code:
Private Sub Worksheet_Change(ByVal Target As Range)
' If Target.Count > 1 Then Exit Sub
' If Target.Column > 2 Then Exit Sub
Application.EnableEvents = False
If Target.Column = 6 Then
If Target.Offset(0, 1).Value <> "" Then
MsgBox "You must only fill in one of the two columns"
Target.ClearContents
GoTo ExitSub
End If
End If
If Target.Column = 7 Then
If Target.Offset(0, -1).Value <> "" Then
MsgBox "You must only fill in one of the two columns"
Target.ClearContents
GoTo ExitSub
End If
End If
Dim arrData() As Variant
Dim i As Long
Dim lngRow As Long
Dim myNum As Variant
Dim ws As Worksheet
myNum = Target.Value
If Target.Column = 6 Then
With BogieInspectionPoints 'this is a sheet name
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range("a1:b" & lngRow)
End With
End If
If Target.Column = 7 Then
With WagonInspectionPoints 'this is a sheet name
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range("a1:b" & lngRow)
End With
End If
For i = 1 To lngRow
If myNum = arrData(i, 1) Then
Cells(Target.Row, 8).Value = arrData(i, 2)
Exit For
End If
Next
ExitSub:
Application.EnableEvents = True
End Sub
It looks like those sheet variables aren't set.
You will need to add this at the top.
Dim BogieInspectionPoints as Worksheet
Dim WagonInspectionPoints as Worksheet
Set BogieInspectionPoints = ActiveWorkbook.Sheets("BogieInspectionPoints")
Set WagonInspectionPoints = ActiveWorkbook.Sheets("WagonInspectionPoints")
I was assuming there was other code. When you add this line all the With statements should process correctly using the code you posted.
What you're doing with the With statements is shorthanding the object. Instead of writing
BogieInspectionPoints.Range("A1")
'More code
You can write
With BogieInspectionPoints
.Range("A1")
End With
It keeps you from having to write the full object name out.