Compare/match name list in sheet with sheet names and delete extra names from list

[vanhunk]

COMPARE/MATCH NAMES IN LIST IN SHEET WITH THE NAMES OF THE WORKBOOK SHEETS AND DELETE THE NAMES FROM THE LIST THAT DO NOT PRESENT SHEET NAMES: I have a list of names on a sheet. The code must go through this list one by one, and if the name in the list does not present a sheet name, it must be deleted and the entries moved one up. Note that (by preference and design) there are a number of sheet names that will never be present in this list. What is the best way, i.e. shortest and most elegant way of doing it? Thanks

[SamT]

First, Please be aware that all CAPS is considered YELLING and is considered rude. Please refrain in the future. TIA. Also see: FAQ (http://www.vbaexpress.com/forum/faq.php)

The following is not code, it is Code Logic (An algorithm)
For Each Cell in List
On Error GoTo DeleteCell
'Skip Deletion if sheet exists
IF Not Sheets(Cell) is Nothing Then GoTo CellNext
DeleteCell:
Cell.Delete(XlDeleteShiftDirection)
CellNext:
Next Cell

[vanhunk]

First, Please be aware that all CAPS is considered YELLING and is considered rude. Please refrain in the future. TIA. Also see: FAQ (http://www.vbaexpress.com/forum/faq.php)

The following is not code, it is Code Logic (An algorithm)
For Each Cell in List
On Error GoTo DeleteCell
'Skip Deletion if sheet exists
IF Not Sheets(Cell) is Nothing Then GoTo CellNext
DeleteCell:
Cell.Delete(XlDeleteShiftDirection)
CellNext:
Next Cell

Thank you Sam, it is a shame and a pity that people see something that by its very nature is designed to assist them and save time in getting to the heart of the matter is considered to be rude. Well, I suppose we live in a crooked world so I will refrain from using capital letters to assist others, thanks for the heads up.

I pretty much used the same logic, my problem with that was that as the contents of the cells are moved up, it actually missed the "cells" that were moved up past the current point in the spreadsheet.

[SamT]

I don't think that I have been firing all 8 cylinders lately. I know that I know about that problem with deletions.


For i = List.Count to 1 Step - 1
With List
.Cells(i)
'Rest of code
End With

does the deletions from bottom up

[vanhunk]

Hi Sam,
Thank you for the feedback. I have tried something slightly different as can be seen in the attached Excel file. Any comments/suggestions on how it can be improved shortened is always welcome.

The code:
Option Explicit
Sub VerwyderEkstraName()
Dim Kolom, Y As Long 'Used for the column number of the list of contractors.
Dim FirstRow As Long 'Used for the first contractor name.
Dim X As Long 'Used for stepping through the contractor names.
Dim LastRow, Z As Long 'Used to indicate the last contractor name on the list.
Dim wsNaam As String 'Used to name the sheet containing the contractor list.
Dim wsNaampie As String 'Used to compare the name in the list with the sheets in the workbook.

Application.ScreenUpdating = False 'Turn off screen updating to speed up calculations.

wsNaam = "Start Sheet" 'Used to indicate the sheet containing the list of contractors.

FirstRow = Worksheets(wsNaam).Range("ContractorsList").Row + 1
X = FirstRow

Kolom = Range("ContractorsList").Column
Y = Kolom

LastRow = Cells(Rows.Count, Y).End(xlUp).Row
Z = LastRow

'The next line of code is the start of the loop that compares the names in the list with the sheets in the
'workbook:
ToetsLoop:

'MsgBox "X = " & X & "; _
Z + 1 = " & Z 'For debugging/testing only.

If X = Z + 1 Then GoTo Einde 'Determine whether the last name in the list has been dealt with.

wsNaampie = Cells(X, Y).Value 'Name used to compare the name in the list with the sheets in the workbook.

On Error Resume Next
If Evaluate("isref(" & "'" & wsNaampie & "'" & "!A1)") = True Then
If wsNaampie = "" Then GoTo BlankoNaam 'Branch to "BlankoNaam" if cell is empty.

'MsgBox wsNaampie & " bestaan" 'For debuggin/testing only.

X = X + 1 'Go down one name in the list.
'------------------------------------------------------------------------------------------------------
' ELSE:
' These lines delete the name from the list if no sheet with the same name exists,
' then move the names up one position, also when there are no name in the cell:
Else:
BlankoNaam: 'Branch here if the cell being checked contains no name.

'MsgBox wsNaampie & " bestaan nie" 'For debugging/testing only.

Range(Worksheets(wsNaam).Cells(X, Y), Worksheets(wsNaam). _
Cells(X, Y)).Delete Shift:=xlUp

Z = Z - 1 'Move the last row up one as the names moved up by one.
'-------------------------------------------------------------------------------------------------------
End If

'The next line of code takes execution to the start of the loop to compare the next name in the list with
'the sheets in the workbook:
GoTo ToetsLoop

Einde:

Application.ScreenUpdating = True

End Sub

[SamT]

See what you think of this
Sub SamT()
'Sub VerwyderEkstraName()
Dim X As Long

Application.ScreenUpdating = False
On Error Resume Next
With Worksheets("Start Sheet").Range("ContractorsList")
For X = .Count To 2 Step -1
'Dot+Count is the number of cells in "With Range"
If Trim(.Cells(X)) = "" Then 'This cell is empty
.Cells(X).Delete Shift:=xlUp
ElseIf Sheets(.Cells(X)) Is Nothing Then
'If the sheet exists, this branch is not entered
'If the sheet doesn't exist, Resume Next causes the next line
'to be executed
.Cells(X).Delete Shift:=xlUp
End If
Next
End With
Application.ScreenUpdating = True

End Sub

[vanhunk]

Hi Sam,
Thanks for the reply. I like the use of count to determine the number of entries in the list. You will however have to redefine the range every time. Note that in my code "ContractorsList" refer to the heading cell where in your code it refers to the range of entries.

Secondly, your code does not compare the entries in the list with the sheet names, but simply delete every entry in the list one be one, leaving only the top entry. If you don't mind, have a look at the attachment I posted earlier to see what the final result should look like. You can add your code to the modules to test it out.

Regards,
vanhunk

[snb]

Sub M_snb()
For Each cl In Columns(2).SpecialCells(2)
If cl.Row > 4 And cl <> "" Then
If Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
End If
Next

Columns(2).SpecialCells(4).EntireRow.Delete
End Sub

[vanhunk]

Hi snb,
Problems: 1) I do not want to delete the entire row, I want the cells to move up.
2) I do not want to delete the blank "rows" above the list.

I slightly changed your code to do what it is supposed to do, however I do believe you will have a better way of limiting the cells than the "Range("B5:B30")I used.

Thanks

See what you think of this:
Sub Modified_snb()
'Sub M_snb()
For Each cl In Columns(2).SpecialCells(2)
If cl.Row > 4 And cl <> "" Then
If Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
End If
Next

'Columns(2).SpecialCells(4).EntireRow.Delete
'Range("B5:B30").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
'Columns(2).SpecialCells(4).Delete shift:=xlUp

Range("B5:B" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlCell TypeBlanks).Delete shift:=xlUp


End Sub

[snb]

or ?


Sub Modified_snb()
For Each cl In Columns(2).SpecialCells(2, 2)
If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
Next

UsedRange.Columns(2).Offset(4).SpecialCells(4).Delete xlUp
End Sub

[SamT]

Tested with hardcoded range:

If Trim(.Cells(X).Value) = "" Then 'This cell is empty
.Cells(X).Delete Shift:=xlUp
ElseIf Sheets(.Cells(X).Value)
And you will have to define the range. There are empty cells in the list so we can't use .End(xlDown). We don't know what is below the list, so we can't use .End(xlUp).

[vanhunk]

or ?


Sub Modified_snb()
For Each cl In Columns(2).SpecialCells(2, 2)
If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
Next

UsedRange.Columns(2).Offset(4).SpecialCells(4).Delete xlUp
End Sub

Problem:
I get a "Run-time error '424': Object required" message on the last line, not sure why.

Regards,
vanhunk

[snb]

Sub Modified_snb()
For Each cl In Sheet1.Columns(2).SpecialCells(2, 2)
If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
Next

sheet1.UsedRange.Columns(2).Offset(4).SpecialCells(4).Delete xlUp
End Sub

NB Take care something has been entered/formatted in column A

[vanhunk]

Tested with hardcoded range:

If Trim(.Cells(X).Value) = "" Then 'This cell is empty
.Cells(X).Delete Shift:=xlUp
ElseIf Sheets(.Cells(X).Value)
And you will have to define the range. There are empty cells in the list so we can't use .End(xlDown). We don't know what is below the list, so we can't use .End(xlUp).

@SamT

Thanks Sam, it does the job perfectly, I added a line to ensure the ability to use it repeatedly. If we do not do anything below the list, we can aleays .End(xlUp).

@snb
Please see previous post

Regards,
vanhunk
Sub SamT2_Modified()
'Sub VerwyderEkstraName()
Dim X As Long

Application.ScreenUpdating = False

ActiveWorkbook.Names.Add Name:="ContractorsLys", RefersToR1C1:= _
"='Start Sheet'!R5C2:R100C2"

On Error Resume Next

With Worksheets("Start Sheet").Range("ContractorsLys")

For X = .Count To 2 Step -1
'Dot+Count is the number of cells in "With Range"
If Trim(.Cells(X).Value) = "" Then 'This cell is empty
.Cells(X).Delete Shift:=xlUp
ElseIf Sheets(.Cells(X).Value) Is Nothing Then
'If the sheet exists, this branch is not entered
'If the sheet doesn't exist, Resume Next causes the next line
'to be executed
.Cells(X).Delete Shift:=xlUp
End If
Next
End With
Application.ScreenUpdating = True

End Sub

[snb]

See the attachment: macro in module of sheet16

[vanhunk]

Thanks snb,
It did it, seriously impressive.
Regards,
vanhunk

[vanhunk]

@snb,
Problems:
I have used the code in another workbook, similar setup. My original code and that of SamT worked, but for some reason that I can not fathom your code gives an error message in the following line If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = "" of "Run-time error '13' : Type mismatch"
Here is all the code again:
Sub Modified_snb2()
Dim cl As Range
Application.ScreenUpdating = False
Application.Calculation = xlManual

For Each cl In Sheets("Start sheet").Columns(2).SpecialCells(2, 2)

If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
Next

ws.UsedRange.Columns(2).Offset(4).SpecialCells(4).Delete xlUp

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

End Sub

This is Weird :dunno

[snb]

The cause lies in your worksheet.
Can't tell without seeing it.

NB. ws is unspecified.

Try to do some debugging yourself:


Sub Modified_snb2()

For Each cl In Sheets("Start sheet").Columns(2).SpecialCells(2, 2)
msgbox "isref('" & cl.Value & "'!a1)"
If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = ""
Next
End Sub

[SamT]

@ VanHunk

I try to make my code examples the best beginners code on the site.

snb's examples are the best examples of advanced coding on the site.

IF you do not do anything below the list you can
Set ContractorsLys = Sheets("Start Sheet").Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp))
With ContractorsLys
'
'
'

[vanhunk]

The cause lies in your worksheet. Can't tell without seeing it. NB. ws is unspecified. Try to do some debugging yourself:
Sub Modified_snb2() For Each cl In Sheets("Start sheet").Columns(2).SpecialCells(2, 2) msgbox "isref('" & cl.Value & "'!a1)" If cl.Row > 4 And Not Evaluate("isref('" & cl.Value & "'!a1)") Then cl.Value = "" Next End Sub @snb I will do so thanks, do you have any ideas of what could type of whatever can cause it? Regards, vanhunk

[vanhunk]

@SamT, Appreciated, thanks. Regards, vanhunk