Unable to delete sheets that meet a condition - excel

I keep getting
runtime error 1004 - Application defined or object defined error
for the code below. Could you help me figure out why this is happening?
Option Explicit
Sub DeleteSheet()
Dim Sh As Worksheet
Application.DisplayAlerts = False
For Each Sh In ThisWorkbook.Worksheets
If Application.WorksheetFunction.Search("Generation", Sh.Range("A1").Value, 1) = 1 Then
Sh.Delete
End If
Next Sh
Application.DisplayAlerts = True
End Sub

You can't delete a sheet which is also a control variable in a loop. Use a counter instead to iterate through the sheets, then delete using the counter, eg
dim sheetCount
dim i
sheetCount = ThisWorkbook.Worksheets.Count
for i = sheetCount to 1 step -1
dim sh as Worksheet
set sh = ThisWorkbook.Worksheets(i)
If Application.WorksheetFunction.Search("Generation", sh.Range("A1").Value, 1) = 1 Then
ThisWorkbook.Worksheets(i).Delete
End If
next i

Delete Worksheets Using an Array of Worksheet Names
I couldn't reproduce the exact error.
The covered scenarios producing errors were the following:
when generation was not found in cell A1,
the last sheet cannot be deleted,
when a sheet was very hidden.
VBA has its own FIND or SEARCH equivalent called Instr.
In the workbook containing this code (ThisWorkbook), it will delete all worksheets whose cell A1 contains a string starting with Generation.
Option Explicit
Sub DeleteSheets()
Dim wsCount As Long: wsCount = ThisWorkbook.Worksheets.Count
Dim wsNames() As String: ReDim wsNames(1 To wsCount) ' Worksheet Names Array
Dim ws As Worksheet
Dim n As Long
For Each ws In ThisWorkbook.Worksheets
' Check if 'A1' contains a string starting with 'Generation'.
If InStr(1, CStr(ws.Range("A1").Value), "Generation", _
vbTextCompare) = 1 Then
n = n + 1 ' next array element
wsNames(n) = ws.Name ' write the worksheet name to the array
End If
Next ws
' Check if no worksheet name was added to the array.
If n = 0 Then Exit Sub
' Resize the array to the number of found worksheets.
If n < wsCount Then ReDim Preserve wsNames(1 To n)
' Delete the worksheets, without confirmation, in one go.
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wsNames).Delete
Application.DisplayAlerts = True
End Sub

Related

Unable to assign value to an array

I'm trying to clear values in the sheets that are present in a workbook. I have a list of all possible (valid) sheets, but I won't know which sheet is currently present in the workbook. So, I need to get the worksheets' name, see if it's valid and then clear its contents. Here's what I have so far:
Sub testclear()
Dim validsheets() As Variant, sheetstoclear() As Variant
Dim i as Integer, j As Integer, k As Integer, m as Integer
validsheets() = Array ("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
For i = 1 To Worksheets.count
For j = LBound(validsheets) to UBound(validsheets)
If Worksheets(i).Name = validsheets(J) Then
sheetstoclear(k) = Worksheets(i).Name
k = k +1
End If
Next j
Next i
For m = LBound(sheetstoclear) to UBound(sheetstoclear)
Sheets(sheetstoclear(m+1)).Cells.clear
Next m
End Sub
If I execute the above code, I get the following error -
Run-time error'9':
Subscript out of range
Iterate the sheets collection and clear the sheet directly without creating a sheetstoclear array first.
Option Explicit
Sub testclear()
Dim ws As Worksheet, validsheets, var
validsheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
For Each ws In ThisWorkbook.Sheets
For Each var In validsheets
If var = ws.Name Then
ws.Cells.Clear
Exit For
End If
Next
Next
End Sub
Please, try the next simple way:
Dim ws As Worksheet
For Each ws In Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"))
ws.UsedRange.Clear
Next

I need to copy a specific range in multiple sheets and paste them on a final sheet

There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?
Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*
It will be much appreciated if you help me get through this hard task
Thank you
You can use a For...Next loop for this:
Sub Tester()
Dim n As Long, c As Range
Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
'loop through sheets
For n = 2 To 23
'convert n to string to get the correct sheet
' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3")
c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
Set c = c.Offset(1, 0) 'next destination
End With
Next n
End Sub
You can do something like this:
Sub copyPaste()
Dim survey_sheet As Worksheet, count As Long
count = 1 'start pasting from this row
For Each survey_sheet In ThisWorkbook.Sheets
If survey_sheet.Name <> "ALL SURVEY" Then
survey_sheet.Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
count = count + 1
End If
Next survey_sheet
End Sub
As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.
The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.
Copy Ranges by Rows
Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.
The Code
Option Explicit
Sub copyByRows()
Const dstName As String = "ALL SURVEY"
Const dstFirst As String = "E2"
Const srcRange As String = "U3:X3"
Const Delimiter As String = ","
Dim ExceptionsList As String
ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
arl.Add ws.Range(srcRange).Value
End If
Next ws
Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
Dim Item As Variant
Dim i As Long
Dim j As Long
Dim k As Long
For Each Item In arl
For i = 1 To srCount
k = k + 1
For j = 1 To cCount
Data(k, j) = Item(i, j)
Next j
Next i
Next Item
dst.Range(dstFirst).Resize(k, cCount).Value = Data
End Sub

Copy specific sheet names from range

I need help and I'm hoping someone here can help me :)
I have a workbook that runs some reports from Avaya CMS. It runs the report and creates a new sheet for each persons name on the MAIN sheet. << This part works wonderfully.
My issue is I cannot figure out how to use that range of names on the MAIN sheet to select only those specific sheets and then copy them to a new workbook.. There's 2 other hidden sheets as well.. Which is why I think using the range of names is easier but I'm open to anything at this point.
Here's an screeshot of what it looks like :
Sorry, I couldn't figure out how to upload the workbook here but the image should, hopefully, be good enough. Thank you for your time and help!
Here's an image with the hidden sheets.
I need it to exclude the first 3 sheets/
And here's the code:
Sub Macro1()
Dim sheetArray() As String
Dim i As Integer
i = 0
For Each c In MainSheet.Range("A2:A20").Cells
ReDim Preserve sheetArray(0 To i)
sheetArray(i) = c.Value
i = i + 1
Next
Sheets(sheetArray).Select
End Sub
Sub move_Sheets()
Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")
Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)
For a = 2 To i
shArray(a - 2) = mSH.Range("A" & a).Value
Next a
ThisWorkbook.Sheets(shArray).Move
End Sub
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, sheetIndex As Long
Dim SheetName As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Main")
'Last row of column where the names appears
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop the column from row 2 to last row
For i = 2 To LastRow
'Set Sheet name
SheetName = .Range("A" & i).Value
'Check if the sheet with the SheetName exists
If DoesSheetExists(SheetName) Then
'Insert the code to code
sheetIndex = Workbooks("Book2").Sheets.Count
ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
Else
End If
Next i
End With
End Sub
Function DoesSheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function

Remove obsolete values from table that is populated with a For Each loop?

The current code loops through each worksheet that begins with "Rev" and returns a specific cell value, which populates a table on my worksheet "Table".
This works fine. However, if a Rev worksheet is removed, the value in the Table worksheet remains.
With that background info, what is a solution to only keep current Rev worksheet values from populating the table?
Sub Rev_loop()
Dim ws As Worksheet
Dim n As Long
For Each ws In Worksheets
If ws.Name Like "Rev*" Then
n = n + 1
Worksheets("Table").Cells(n).Value = ws.Range("B2").Value
End If
Next ws
End Sub
Clear the table first. Then iterate through the Worksheets as before.
Something like this:
Worksheets("Table").Range("B2:B99").ClearContents
If you don't want to clear the table before your next loop, you have to remember the sheet's names somewhere.
By this example you can store the sheet's names and their value together in the first two columns:
Sub Rev_loop()
Dim ws As Worksheet
Dim n As Long
With Worksheets("Table")
n = 0
For Each ws In Worksheets
If ws.Name Like "Rev*" Then
n = n + 1
.Cells(n, 1).Value = ws.Name
.Cells(n, 2).Value = ws.Range("B2").Value
End If
Next ws
End With
End Sub
By this second loop, you compare the stored sheet's names and delete all rows with outdated names:
Sub Correct_loop()
Dim ws As Worksheet
Dim StillValid As Boolean
Dim n As Long
With Worksheets("Table")
For n = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
StillValid = False
For Each ws In Worksheets
If ws.Name = .Cells(n, 1).Value Then
StillValid = True
Exit For
End If
Next ws
If Not StillValid Then .Rows(n).Delete
Next n
End With
End Sub

Find all worksheets with a specific named range

I am running a routine in MS Access manipulating MS Excel.
I am making a consolidate report worksheet from all of the worksheets in the workbook. Only some of the worksheet have a named range of "dockName". My routine is making an array with the dock names and the associated worksheet names. On the consolidated worksheet I am including a list of dock names and hyperlinks to their associated worksheets.
The code below works but it transverses the worksheets twice and I believe there is a better way to get the total number of worksheets with a named range of "dockName"
' cycle through each worksheet to find out if
' the worksheet has a named range of "dockName"
' if the named range is found increment irow
For Each ws In wbWorking.Worksheets
On Error Resume Next
Set rngDock = ws.Range("dockName")
On Error GoTo err_trap
If Not rngDock Is Nothing Then
irow = irow + 1
End If
Next ws
If Not ws Is Nothing Then Set ws = Nothing
' redim an array with the appropriate number of rows
icol = 1
ReDim vDockSheetNames(irow, icol)
irow = 0
' cycle through the worksheets and gather the
' dockName and worksheet Name into vDockSheetNames array
For Each ws In wbWorking.Worksheets
On Error Resume Next
Set rngDock = ws.Range("dockName")
On Error GoTo err_trap
If Not rngDock Is Nothing Then
vDockSheetNames(irow, 0) = rngDock.Value2
vDockSheetNames(irow, 1) = ws.name
irow = irow + 1
End If
Next ws
It is no problem whatsoever to ReDim lots of times.
Sub TestRedim()
Dim myAr() As String
Dim i As Long
Dim TimeStart As Single
TimeStart = Timer()
For i = 1 To 1000000
ReDim Preserve myAr(1 To i)
myAr(i) = "Sheet " & i
Next i
MsgBox "That took " & Format(Timer - TimeStart, "0.000") & " seconds.", vbInformation
End Sub
I had to crank up the number of loops to 1 Million to get the time over 1 second.
This takes my computer 1.1 seconds. With
Dim myAr(1 To 1000000) As String
and without the ReDim line it's 0.4 seconds. Not really worth any further thoughts.
So as SJR wrote, ReDim in your first loop. Looping the Worksheets collection and checking for named ranges is more expensive by magnitudes.
Based on the suggestion of #SJR and supporting suggestion by #Andre I generated the following function which returns the count of a given named range in a given workbook. The return value may be used to redim an array. This functions and markedly faster than transversing the worksheet collect and testing for a named range.
Function getCountOfNamedRanges(ByRef wb As Excel.Workbook, ByVal rngName As String) As Integer
' return the number of times a given rngName appears in the given workbook
Dim nm As Variant
Dim nms As Names
Dim i As Integer
Dim iReturn As Integer
Set nms = wb.Names
For i = 1 To nms.Count
If InStr(1, nms(i).Name, rngName) Then iReturn = iReturn + 1
Next i
countNameRanges = iReturn
End Function

Resources