I have a spreadsheet which is used enterprise-wide. I am trying to put in checks such that certain fields are required. Specifically, columns B (last name) AND C (first name) are required, OR Column D (Organization) is required. However, B, C, and D cannot all three be filled in. If the row has any data at all in it, B and C or D are required.
My idea is to put in a button to run this macro. That I can do.
I've tried many things at this point. I can include the spreadsheet in case anyone can offer any insight. I had a macro that worked on a test sheet, but does not work on this sheet, if that will help at all.
Here is the macro
Sub CheckVal2()
Dim ws As Worksheet
Dim wsCurr As Worksheet
Dim cel As Range
Dim lngLastRow As Long
Dim lngRow As Long
For Each ws In Worksheets
If Left$(ws.Name, 7) = "Current" Then
Set wsCurr = ws
Exit For
End If
Next
With wsCurr
lngLastRow = .Range("B5000").End(xlUp).Row
For lngRow = 2 To lngLastRow
For Each cel In .Range("B" & lngRow & ":E" & lngRow)
If cel = "" Then
MsgBox "First and Last Name or HCO must be populated."
Cancel = True
Exit Sub
End If
If cel <> "" Then
If .Cells(lngRow, "D") = "" Then
If .Cells(lngRow, "B") = "" Or _
.Cells(lngRow, "C") = "" Then
MsgBox "First and Last Name or HCO must be populated."
Cancel = True
Exit Sub
End If
End If
End If
Next
Next
End With
'
End Sub
Once you get past whatever is causing the error trying to access wsCurr (which I suspect is just a case of the worksheet not existing), you should modify your code as follows:
With wsCurr
lngLastRow = .Range("E5000").End(xlUp).Row
For lngRow = 2 To lngLastRow
'First check whether first/last name has been consistently advised
If (.Cells(lngRow, 2) = "") <> _
(.Cells(lngRow, 3) = "") Then
MsgBox "Row " & lngRow & " - First Name and Last Name must both be advised or both be blank"
Cancel = True ' I assume this is a global variable?
Exit Sub
End If
'Now check that last name has not been advised if HCO has been, and vice-versa
If (.Cells(lngRow, 2) = "") = _
(.Cells(lngRow, 4) = "") Then
MsgBox "Row " & lngRow & " - First and Last Name, or HCO, must be populated but not both."
Cancel = True
Exit Sub
End If
Next
End With
This will get around the existing problem with your tests, which (as far as I can tell) aren't allowing for the case where all three columns have been advised.
I also changed the column on which lngLastRow was being set because, if it is set based on column B and the last row(s) of your data only contained values in column C and/or D, those final row(s) would not be being tested.
Related
I am using Excel 2010.
I have some VBA code which creates a unique key and then looks for duplicate unique key entries. Any duplicates are coloured in red.
I need to automate this a little further. If there is a duplicate unique key, copy the information from the newest entry, and paste it into the line where the original entry is. I then want the newest entry deleted.
The unique key is a concat of the customer name and the date the file was created. There will only ever be at most one duplicate entry per customer and that will be because the date the file was last updated has changed. I need the duplicate concat entry with the newest date to copy the info over the top of the entry with the oldest date on it then delete the original newest date entry. This is because we have other checks that have been completed further along the sheet that we need to keep intact.
Ideally I would like for the message box to still advise how many duplicate entries were found and for the entry to remain coloured red once the copy/paste/delete has taken place to highlight the entry that has been changed.
Private Sub CommandButton1_Click()
'Start of Concatenate Code
Dim i As Integer
Dim r As Range
On Error Resume Next
' Tells Excel to look in column 3 (Column C) for the last one with data in it
lRow = Cells(Rows.Count, 3).End(xlUp).Row
' Tell Excel to focus on cells 4 to 5000
For i = 4 To lRow
' Tell Excel to paste the contents of cell 4 (column D) followed by |
' then the contents of cell 8 (column H) into cell 2 (column B)
Cells(i, 2).Value = Cells(i, 11) & " | " & Cells(i, 7)
Next i
'End of Concatenate Code
'Start of Check for Duplicates code
Dim j As Integer
Dim myCell As Range
Dim myRange As Integer
myRange = Range("A4:A5000").Count
j = 0
' Select the Range
For Each myCell In Range("B4:B5000")
' Check that the cells in the range are not blank
If WorksheetFunction.CountIf(Range("B4:B5000"), myCell.Value) > 1 Then
' Colour the duplicate entries in red
myCell.EntireRow.Interior.ColorIndex = 3
j = j + 1
End If
Next
MsgBox "There are " & j & " duplicates found." & vbCrLf & vbCrLf & _
"Any duplicates have been highlighted in red.", vbInformation + vbOKOnly, _
"Duplicate Entry Checker"
' End of Check for Duplicates code
End Sub
Screenshot of spreadsheet
Thank you #rickmanalexander, I just tried your code (and changed the name of the sheet) but I get a subscript out of range error with the number 9 in the msgbox title. There must be something i have missed but i am not sure what?
Here is the code I used:
Private Sub CommandButton1_Click()
On Error GoTo CleanFail
Dim wrkSht As Worksheet
Set wrkSht = Sheets("Raw Data")
Dim lRow As Long
lRow = wrkSht.Cells(wrkSht.Rows.Count, 3).End(xlUp).Row
Dim arrySheet As Variant
'get the worksheet data into an array
arrySheet = wrkSht.Range("D1:H" & lRow).Value2
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim keyValue As Variant
Dim i As Long
Dim rowNum As Long
Dim dupCount As Long
For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)
'a concatenated key consisting of the:
'row number
'customer's name
keyValue = Join(Array(i, arrySheet(i, 1)), "|")
If Not dict.Exists(keyValue) Then
dict(keyValue) = arrySheet(i, 8) 'save the date for this unique key
Else
'if we make it here, then this is a duplicate customer
'for which we want to check the date
'If the current row's date is greater than the previouly saved date, then
'delete the current row
'determine the row umber for the previously saved entry
'place the most recent date in place of the old date
'color it red
'increase the duplicate counter
If arrySheet(i, 8) > dict(keyValue) Then
wrkSht.Rows(i).EntireRow.Delete
rowNum = CLng(Split(keyValue, "|")(0))
wrkSht.Cells(rowNum, "B").Value = CDate(arrySheet(i, 8))
wrkSht.Rows(rowNum).EntireRow.Interior.ColorIndex = 3
dupCount = dupCount = dupCount + 1
End If
End If
'clear variables
keyValue = vbNullString: rowNum = 0
Next i
MsgBox "There were " & dupCount & " duplicates found." & _
vbCrLf & vbCrLf & _
"Any duplicates have been highlighted in red.", _
vbInformation + vbOKOnly, "Duplicate Entry Checker"
CleanExit:
Exit Sub
CleanFail:
MsgBox Err.Description, vbCritical, Err.Number
Resume CleanExit
End Sub
Edit:
OP was getting Error 9 subscript out of range, because I used arrySheet(i, 8) instead of arrySheet(i, 4). I was thinking that I defined the array from the range starting at column A. Simple mistake with an easy fix.
The Dictionary Object is the perfect candidate for duplicate checks, so that is what I went with. The code below is untested, but should work for your needs.
Option Explicit
Private Sub CommandButton1_Click()
On Error GoTo CleanFail
Dim wrkSht As Worksheet
Set wrkSht = Sheets("Raw Data")
Dim lRow As Long
lRow = wrkSht.Cells(wrkSht.Rows.Count, 3).End(xlUp).Row
Dim arrySheet As Variant
'get the worksheet data into an array
arrySheet = wrkSht.Range("D1:H" & lRow).Value2
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim keyValue As Variant
Dim i As Long
Dim rowNum As Long
Dim dupCount As Long
For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)
'a concatenated key consisting of the:
'row number
'customer's name
keyValue = Join(Array(i, arrySheet(i, 1)), "|")
If Not dict.Exists(keyValue) Then
dict(keyValue) = arrySheet(i, 4) 'save the date for this unique key
Else
'if we make it here, then this is a duplicate customer
'for which we want to check the date
'If the current row's date is greater than the previouly saved date, then
'delete the current row
'determine the row umber for the previously saved entry
'place the most recent date in place of the old date
'color it red
'increase the duplicate counter
If arrySheet(i,4) > dict(keyValue) Then
wrkSht.Rows(i).EntireRow.Delete
rowNum = CLng(Split(keyValue, "|")(0))
wrkSht.Cells(rowNum, "B").Value = CDate(arrySheet(i, 4))
wrkSht.Rows(rowNum).EntireRow.Interior.ColorIndex = 3
dupCount = dupCount = dupCount + 1
End If
End If
'clear variables
keyValue = vbNullString: rowNum = 0
Next i
MsgBox "There were " & dupCount & " duplicates found." & _
vbCrLf & vbCrLf & _
"Any duplicates have been highlighted in red.", _
vbInformation + vbOKOnly, "Duplicate Entry Checker"
CleanExit:
Exit Sub
CleanFail:
MsgBox Err.Description, vbCritical, Err.Number
Resume CleanExit
End Sub
In my problem:
First, I need to find "Unit Name" in Column B.
If it found "Unit Name" it should look for "First Name:" in Column D and copy 5 cell right. ("Obama" in I10)
Paste the name "Obama" to Unit Name sheet. (Paste "Obama" to Sheet "1" A1)
I am new in coding therefore i don't know too much about it. I tried with some codes but it is not efficient.
Here is an image to show my problem.
Sub Test()
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim z As Integer
For i = 1000 To 1 Step -1
If Range("B" & i).Value = "Unit Name" Then
m = 2
m = i + 1
n = i - 18
If Range("D" & n).Value = "First Name:" Then
m = Range("B" & m).Value + 1
Range("H" & n).Copy
Sheets(m).Range("B7").PasteSpecial xlPasteValues
End If
End If
Next i
End Sub
You don't need all those integer variables, you can use a few Range variables instead:
Sub find_name()
Dim mainWS As Worksheet, altWS As Worksheet
Dim unitCel As Range, fNameCell As Range
Set mainWS = Worksheets("Sheet2") 'CHANGE AS NEEDED
Set altWS = Worksheets("Sheet1")
With mainWS
Set unitCel = .Range("B:B").Find(What:="Unit Name")
If Not unitCel Is Nothing Then
Set fNameCell = .Range("D:D").Find(What:="First Name:").Offset(0, 5)
altWS.Range("A1").Value = fNameCell.Value
End If
End With
End Sub
May need to tweak this, depending on where your data is. I am assuming "Obama" could be any text, that is three columns right of column D, where "First Name:" is found.
Sub Shift_Over5()
Dim i As Long
'Sheet name should be a string
Dim SheetName As String
Dim FirstName As Range
Dim UnitName As Range
'Dim l As Byte --> I changed it to lUnitSheetLastrow, because we need to copy the data from sheet1 to sheet 1,2...
' then you need to check the last row of unit sheet and write data to the last row + 1.
Dim lUnitSheetLastrow As Long
Dim FirstMatch As Variant
Dim Start
Start = VBA.Timer
For i = 1 To 40000 Step 1
'For clear code and easy to follow, you need to mention the sheet you want to interact
'Here i use 'Activesheet', i assume that the current sheet is sheet1
If ActiveSheet.Range("A" & i).Value = "Unit Name" Then
' i think we dont need this code line, because we identified the cell in column B has value is "Unit Name"
'Set UnitName = Range("A:A").Find(what:="Unit Name")
' Here you dont need to use Offset
'SheetName = UnitName.Offset(1, 0).Value
SheetName = ActiveSheet.Range("A" & (i + 1)).Value
' Find "First Name" in 20 rows in column E.
' What happen if i<20, the nextline will show the error, because the minimum row is 1
If i < 40 Then
Set FirstName = ActiveSheet.Range("D1" & ":D" & i).Find(what:="First Name:")
Else
Set FirstName = ActiveSheet.Range("D" & i & ":D" & (i + 40)).Find(what:="First Name")
End If
' make sure the SheetName is not empty and Unit sheet is existing in you workbook then copy the first name to unit sheet
If SheetName <> "" And CheckWorkSheetAvailable(SheetName) Then
' Check the first name is not nothing
If Not FirstName Is Nothing Then
'Check if the cell B7 in unit sheet empty or not
If Worksheets(SheetName).Range("H7").Value = "" Then
'if empty, write to B7
Worksheets(SheetName).Range("H7").Value = FirstName.Offset(1, 0).Value
Else
'else, Find the lastrow in column D of unit sheet
lUnitSheetLastrow = Worksheets(SheetName).Cells(Worksheets(SheetName).Rows.Count, 1).End(xlUp).Row
'Write data to lastrow +1
Worksheets(SheetName).Range("A" & (lUnitSheetLastrow + 1)).Value = FirstName.Offset(, 1).Value
End If
End If
End If
'You forgot to put end if here
End If
Next i
Debug.Print Round(Timer - Start, 3)
End Sub
Function CheckWorkSheetAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = SheetName Then
CheckWorkSheetAvailable = True
Exit For
End If
Next
End Function
thank you everyone I found the answer.
Forgive me, as this may be very simple. I am trying to create a VBA macro that quickly gets statistics from raw data and puts them in a table. The raw data comes in this format:
(They will not always be in groups of three)
How would I get the range for all of a category, and then use that same range for Columns B and C to get the statistics I need?
The below code get you the row numbers of each category and assumes there is no break in content on column B, your question was to get the content of columns C:D by category, having these row values will enable you to code to get the content of C:D.
Public Sub Sample()
Dim WkSht As Worksheet
Dim StrCategory As String
Dim LngRow As Long
Dim LngRowStart As Long
Set WkSht = ThisWorkbook.Worksheets("RawData")
'Take note of the category we are one
StrCategory = WkSht.Range("A" & 2).Value
'Take not of the row the category started on
LngRowStart = 2
'Look to the next row
LngRow = 3
'Loop through the data until column B has no value, signifying the end of the dataset
Do Until WkSht.Range("B" & LngRow) = ""
'Go to the next row until we are given a new category or make it to the end of the dataset
Do Until (WkSht.Range("A" & LngRow) <> "") Or (WkSht.Range("B" & LngRow) = "")
LngRow = LngRow + 1
Loop
'Talk in the immediate pane
Debug.Print StrCategory & " is on rows " & LngRowStart & " to " & LngRow - 1
'Get the next values
StrCategory = WkSht.Range("A" & LngRow)
LngRowStart = LngRow
'Move on
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
End Sub
Below is the input data I gave it: -
Below is the output from the code: -
You could use some If statements and pull this all into an array, but it seems more direct to just fill in the blanks
Sub FillColA()
Dim LastRow As Long
LastRow = Application.WorksheetFunction.CountA(Range("B:B"))
Range("A2:A" & LastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I have this code (This code is in Access VBA which tries to read an excel file and after checking, possibly import it):
Set ExcelApp = CreateObject("Excel.application")
Set Workbook = ExcelApp.Workbooks.Open(FileName)
Set Worksheet = Workbook.Worksheets(1)
now I want to iterate over all rows of the excel worksheet. I want something such as this:
for each row in Worksheet.rows
ProcessARow(row)
next row
where
function ProcessARow(row as ???? )
' process a row
' how Should I define the function
' how can I access each cell in the row
' Is there any way that I can understand how many cell with data exist in the row
end function
My questions:
How to define the for each code that it iterate correctly on all
rows that has data?
How to define ProcessARow properly
How to get the value of each cell in the row.
How to find how many cell with data exist in the row?
Is there any way that I detect what is the data type of each cell?
edit 1
The link solves on problem :
How to define the for each code that it iterate correctly on all rows that has data?
but what about other questions?
For example, how to define ProcessARow correctly?
If you need the values in the Row, you need use the 'Value' Property and after do an cycle to get each value
for each row in Worksheet.rows
Values=row.Value
For each cell in Values
ValueCell=cell
next cell
next row
Unfortunately you questions are very broad however I believe the below sub routine can show you a few ways of achieving what you are after. In regards to what datatype each cell is more involved as it depends what data type you wish to compare it to however I have included some stuff to hopefully help.
sub hopefullyuseful()
dim ws as worksheet
dim rng as Range
dim strlc as string
dim rc as long, i as long
dim lc as long, j as long
dim celltoprocess as range
set ws = activeworkbook.sheets(activesheet.name)
strlc = ws.cells.specialcells(xlcelltypeLastCell).address
set rng = ws.range("A1:" & lc)
rc = rng.rows.count()
debug.print "Number of rows: " & rc
lc = rng.columns.count()
debug.print "Number of columns: " & lc
'
'method 1 looping through the cells'
for i = 1 to rc
for j = 1 to lc
set celltoprocess = ws.cells(i,j)
'this gives you a cell object at the coordinates of (i,j)'
'[PROCESS HERE]'
debug.print celltoprocess.address & " is celltype: " & CellType(celltoprocess)
'here you can do any processing you would like on the individual cell if needed however this is not the best method'
set celltoprocess = nothing
next j
next i
'method 2 looping through the cells using a for each loop'
for each celltoprocess in rng.cells
debug.print celltoprocess.address & " is " & CellType(celltoprocess)
next celltoprocess
'if you just need the data in the cells and not the actual cell objects'
arrOfCellData = rng.value
'to access the data'
for i = lbound(arrOfCellData,1) to ubound(arrOfCellData,1)
'i = row'
for j = lbound(arrOfCellData,2) to ubound(arrOfCellData,2)
'j = columns'
debug.print "TYPE: " & typename(arrOfCellData(i,j)) & " character count:" & len(arrOfCellData(i,j))
next j
next i
set rng=nothing
set celltoprocess = nothing
set ws = nothing
end sub
Function CellType(byref Rng as range) as string
Select Case True
Case IsEmpty(Rng)
CellType = "Blank"
Case WorksheetFunction.IsText(Rng)
CellType = "Text"
Case WorksheetFunction.IsLogical(Rng)
CellType = "Logical"
Case WorksheetFunction.IsErr(Rng)
CellType = "Error"
Case IsDate(Rng)
CellType = "Date"
Case InStr(1, Rng.Text, ":") <> 0
CellType = "Time"
Case IsNumeric(Rng)
CellType = "Value"
End Select
end function
sub processRow(byref rngRow as range)
dim c as range
'it is unclear what you want to do with the row however... if you want
'to do something to cells in the row this is how you access them
'individually
for each c in rngRow.cells
debug.print "Cell " & c.address & " is in Column " & c.column & " and Row " & c.row & " has the value of " & c.value
next c
set c = nothing
set rngRow = nothing
exit sub
if you want your other questions answered you will have to be more specific as to what you are trying to accomplish
While I like the solution offered by #krazynhazy I believe that the following solution might be slightly shorter and closer to what you asked for. Still, I'd use the CellType function offered by Krazynhazy rather than all the Iif I currently have in the below code.
Option Explicit
Sub AllNonEmptyCells()
Dim rngRow As Range
Dim rngCell As Range
Dim wksItem As Worksheet
Set wksItem = ThisWorkbook.Worksheets(1)
On Error GoTo EmptySheet
For Each rngRow In wksItem.Cells.SpecialCells(xlCellTypeConstants).EntireRow.Rows
Call ProcessARow(wksItem, rngRow.Row)
Next rngRow
Exit Sub
EmptySheet:
MsgBox "Sheet is empty." & Chr(10) & "Aborting!"
Exit Sub
End Sub
Sub ProcessARow(wksItem As Worksheet, lngRow As Long)
Dim rngCell As Range
Debug.Print "Cells to process in row " & lngRow & ": " & wksItem.Range(wksItem.Cells(lngRow, 1), wksItem.Cells(lngRow, wksItem.Columns.Count)).SpecialCells(xlCellTypeConstants).Count
For Each rngCell In wksItem.Range(wksItem.Cells(lngRow, 1), wksItem.Cells(lngRow, wksItem.Columns.Count)).SpecialCells(xlCellTypeConstants)
Debug.Print "Row: " & lngRow, _
"Column: " & rngCell.Column, _
"Value: " & rngCell.Value2, _
IIf(Left(rngCell.Formula, 1) = "=", "Formula", IIf(IsDate(rngCell.Value), "Date", IIf(IsNumeric(rngCell.Value2), "Number", "Text")))
Next rngCell
End Sub
Note, that you have to call the sub to call a row must also include the sheet on which a row should be processed.
(pic link below for this example): The data starts on row "A11", one block of data is A11 to A14, I need to search that range to see if it contains a member name from a list on sheet 2, for example Erik Christensen, if the list on sheet 2 doesnt have that name I need to delete rows A11 thru A14 and continue to the next block. The list on sheet 2 will have a varying amount of members to check so that needs to be taken into consideration. Once all the rows have been processed, I need to sorth them back to start at row A11.Please see pic and I will be extremely thankful for any help.
Sheet 1
For the below answer, I have made a few assumptions:
Your data will always start on row 11 of the first sheet in the
workbook.
The search term will always be found in the second row, below
Object:...
The data will always present in rows of 4, as shown in the picture,
with End: in the 4th row.
The list of valid names is in column A (beginning on A1) of the
second sheet in the workbook.
By "sorted back to start on row A11", I assume you mean that the
remaining blocks of data should start on row A11 and continue to the
end of the data, not that any actual sorting (i.e. by name) is
required.
This code will loop through all blocks of data (beginning with the last one, since we are deleting rows). If any of the names in column A of the second sheet appear in the block of data, that block is skipped. Otherwise, if no names appear, that block is deleted.
Sub SearchAndDeleteList()
Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean
'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
If LRow >= 11 Then
'Make sure there are at least 11 rows of data
i = LRow
'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
Do
BMatch = False
For j = 1 To LListRow
'Test this block to see if the value from j appears in the second row of data
If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
BMatch = True
Exit For
End If
Next j
'Application.StatusBar = "Match status for row " & i & ": " & BMatch
If Not BMatch Then
'Loop backwards to find the starting row (no lower than 11)
For j = i To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
Next j
Sheets(1).Rows(j & ":" & i).Delete
i = j - 1
Else
'Find next block
If i > 11 Then
For j = i - 1 To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
Next j
i = j
Else
i = 10 'Force the loop to exit
End If
End If
'Application.StatusBar = "Moving to row " & i
Loop Until i < 11
'Loop back through and delete any blank rows
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'MsgBox "Second checkpoint: new last row of data is " & LRow
For i = LRow To 11 Step -1
If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
Next i
End If
'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
thanks to Nick's cracking actual OP's needs, I hereby propose a solution that should be more maintainable and/or changeable as per Op's future needs
Option Explicit
Sub SearchAndDeleteList2()
Dim dataSht As Worksheet
Dim dataRng As Range, namesRng As Range, cell As Range, rangeToDelete As Range
Dim firstAddress As String
'------------------------------
' setting stuff - begin
Set dataSht = ThisWorkbook.Sheets("Sheet1Data") '<== change 'data' sheet as per your needs
With dataSht
Set dataRng = .Range("A11:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
If dataRng.Rows(1).row < 11 Then Exit Sub
With ThisWorkbook.Sheets("Sheet2Names") '<== change 'names' sheet as per your needs
Set namesRng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
Call ApplicationSet(False, False, xlCalculationManual, False)
' setting stuff - end
'------------------------------
'------------------------------
' core code - begin
Set cell = dataRng.Find("End:", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not MyMatch(GetName(cell.Offset(-2)), namesRng) Then Call UpdateRngToDelete(rangeToDelete, dataSht.Rows(cell.row).Offset(-3).Resize(4))
Set cell = dataRng.FindNext(cell)
Loop While cell.Address <> firstAddress
rangeToDelete.Delete
End If
' core code - end
'------------------------------
Call ApplicationSet(True, True, xlCalculationAutomatic, True)
End Sub
Function GetName(cell As Range) As String
Dim iIni As Integer
Dim iEnd As Integer
iIni = InStr(cell.value, """") '<== the 'name' is always preceeded by '"' character
iEnd = InStr(cell.value, "\") '<== the 'name' is always follwed by '/' character
GetName = Mid(cell.value, iIni + 1, iEnd - iIni - 1)
End Function
Sub UpdateRngToDelete(baseRng As Range, toBeAddedRng As Range)
If baseRng Is Nothing Then
Set baseRng = toBeAddedRng
Else
Set baseRng = Union(baseRng, toBeAddedRng)
End If
End Sub
Function MyMatch(value As String, rng As Range) As Boolean
MyMatch = Not IsError(Application.Match(value, rng, 0))
End Function
using separate functions or subs makes it easier (and faster!) to keep control and debug future code changes