I have a macro where I create a number of sheets that take their names from the values in column c, cell 7 onwards in a sheet called "Schedule". I am using the following code for that
Sub CreateDataSheets()
'Updateby Extendoffice 20161215
Dim xRg As Variant
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("C7", Range("C7").End(xlDown))
If Not IsError(xRg) Then
If xRg <> "" Then
If Not WorksheetExists((xRg)) Then
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count), Type:="L:\London\General\Reference & Tools\Software\BIM\IiA_Specifications\Excel\Uk Specification Template.xltx"
ActiveSheet.Name = xRg.Value
End With
End If
End If
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Now I need another Macro where if I change or delete any of these values in Column C, I want to create new updated ones and delete all the sheets that are redundant. While doing this, I want to retain the sheets called Schedule, Home and CoverSheet. Below is the code I tried to write but that would not work.
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne() As Variant
Dim wsName As Variant
Dim Matched As Boolean
Dim DirArray As Variant
DirArray = Range("C7:C11")
ArrayOne = Array("Home", "Schedule", "CoverSheet", DirArray.Value)
Application.DisplayAlerts = False
For Each ws In Sheets
Matched = False
For Each wsName In ArrayOne
If wsName = ws.Name Then
Matched = True
Exit For
End If
Next
If Not Matched Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
End Sub
Would really appreciate any ideas...
DirArray is beeing created as a Variant and the position 4 of your Array ArrayOne is actually another array and not a string.
To fix it, initialize the ArrayOne just like this:
ArrayOne = Array("Home", "Schedule", "CoverSheet")
Dim Name As Variant
For Each Name In DirArray
If Name <> "" Then
ReDim Preserve ArrayOne(UBound(ArrayOne) + 1)
ArrayOne(UBound(ArrayOne)) = Name
End If
Next
It will also not consider empty values on the range you selected.
Consider changing your removing steps as on Sam's answer
Iterating over a changing set is often a bad idea. Do something like this instead
For i = Sheets.Count to 1 Step -1
If ....
Sheets(i).Delete
End If
Next i
Related
I am trying to write a macro that will prompt the user to open 2 workbooks and then loop through the worksheets in the 2 books comparing their contents and highlighting any differences in yellow. Each piece seems to be working on its own, but I cannot figure out how to set the workbook names as global variables to be used between the functions in my sub. Any help would be appreciated! :)
Public strFile1 As String
Public strFile2 As String
Public wbSource1 As Workbook
Public wbSource2 As Workbook
Public I As Integer
Sub DifferenceCheckBetweenBooks()
Call openIt
Call WorksheetLoop
End Sub
Function openIt()
strFile1 = Application.GetOpenFilename
Workbooks.Open strFile1
Set wbSource1 = Workbooks.Open(strFile1)
strFile2 = Application.GetOpenFilename
Workbooks.Open strFile2
Set wbSource2 = Workbooks.Open(strFile2)
End Function
Function WorksheetLoop()
Dim WS_Count As Integer
WS_Count = Workbooks(wbSource1).Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
Call compareBooks
Next I
End Function
Function compareBooks()
Dim mycell As Range
'For each cell in worksheet that is not the same as compared worksheet, color it yellow
For Each mycell In Workbooks(wbSource1).Worksheets(I).UsedRange
If Not mycell.Value = Workbooks(wbSource2).Worksheets(I).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
Workbooks(wbSource2).Worksheets(I).Cells(mycell.Row, mycell.Column).Interior.Color = vbYellow
End If
Next
Workbooks(wbSource2).Worksheets(I).Select
End Function
I am getting the classic "subscript out of range error" which points to my wbSource1 variable as empty.
Don't do this
Workbooks.Open strFile1
Set wbSource1 = Workbooks.Open(strFile1)
you only need
Set wbSource1 = Workbooks.Open(strFile1)
And as SJR points out:
WS_Count = wbSource1.Worksheets.Count 'plus all other instances of this
You should really refactor your code to remove the globals and use parameters in your methods instead - that's a much safer approach.
Refactored to remove globals:
Sub DifferenceCheckBetweenBooks()
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = OpenIt("Choose first file")
If wb1 Is Nothing Then Exit Sub
Set wb2 = OpenIt("Choose second file")
If wb2 Is Nothing Then Exit Sub
CompareWorkbooks wb1, wb2
End Sub
Sub CompareWorkbooks(wb1 As Workbook, wb2 As Workbook)
Dim i As Long, sht1 As Worksheet, sht2 As Worksheet, c As Range, c2 As Range
For i = 1 To wb1.Worksheets.Count
Set sht1 = wb1.Worksheets(i)
Set sht2 = wb2.Worksheets(i)
For Each c In sht1.UsedRange.Cells
Set c2 = sht2.Range(c.Address)
If c.Value <> c2.Value Then
c.Interior.Color = vbYellow
c2.Interior.Color = vbYellow
End If
Next c
Next i
End Sub
Function OpenIt(msg As String) As Workbook
Dim strFile
strFile = Application.GetOpenFilename(Title:=msg)
If Len(strFile) > 0 Then Set OpenIt = Workbooks.Open(strFile)
End Function
I currently have code were I have a file of data with unique businesses, the vba that I have programmed removes all other businesses but one. I have noticed that the file that I have worked on has legacy data below the rows filled with data I need and I need to remove these to make the file smaller.
Sub ConstructionTools()
Dim ARange As Range
Dim DRange As Range
Dim ws As Worksheet
Dim wsB As Worksheet
Dim filename As String
Set ws = Sheets("Data")
Set wsB = Sheets("Macro")
Set DRange = Nothing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ARange In ws.Range("L1:L28000").Rows
If ARange(1).Value = "BUILDING CONSTRUCTION" Or ARange(1).Value = "CONSTRUCTION SERVICES" Or ARange(1).Value = "HEAVY & HIGHWAY" Or ARange(1).Value = "HEAVY CIVIL - SPS" Then
If DRange Is Nothing Then
Set DRange = ARange
Else
Set DRange = Union(DRange, ARange)
End If
End If
Next ARange
If Not DRange Is Nothing Then DRange.EntireRow.Delete
With ws.Rows(X & ":" & .Rows.Count).Delete
End With
End Sub
I put some code in from here How do I delete everything below row X in VBA/Excel?, but I am getting the
compile error Invalid or unqualified reference
The code worked before adding in this line
With ws.Rows(X & ":" & .Rows.Count).Delete
how would I go about deleting the rows behind the cleaned up data?
Option Explicit
Sub ConstructionTools()
'Dim ARange As Range
'Dim DRange As Range
Dim ws As Worksheet
'Dim wsB As Worksheet
'Dim filename As String
Set ws = Sheets("Data")
'Set wsB = Sheets("Macro")
'Set DRange = Nothing
Dim RowIndex as long
Dim Counter as long
With ws.Range("L1:L28000")
Dim RowsToDelete() as string
Redim rowstodelete(1 to .rows)
For rowindex = .rows to 1 step -1
Select case .cells(rowindex,1).value
Case "BUILDING CONSTRUCTION", "CONSTRUCTION SERVICES", "HEAVY & HIGHWAY" Or "HEAVY CIVIL - SPS"
Counter = counter + 1
Rowstodelete(counter) = .cells(rowindex,1).address
End select
Next rowindex
End with
If counter >0 then
Redim preserve RowsToDelete(1 to Counter)
With application
.screenupdating = false
.displayalerts = false
.calculation = xlcalculationmanual
Ws.range(strings.join(RowsToDelete,",")).entirerow.delete
.screenupdating = true
.displayalerts = true
.calculation = xlcalculationautomatic
End if
End sub
Untested and written on mobile, sorry for bad formatting. Code attempts to add the addresses of all rows which need to be deleted to an array, and then tries to delete all added rows in one go.
can you please advise why the below code does not select the visible sheets, but ends in a runtime error. This is driving me crazy. Thanks for any help.
Sub SelectSheets1()
Dim mySheet As Object
Dim mysheetarray As String
For Each mySheet In Sheets
With mySheet
If .Visible = True And mysheetarray = "" Then
mysheetarray = "Array(""" & mySheet.Name
ElseIf .Visible = True Then
mysheetarray = mysheetarray & """, """ & mySheet.Name
Else
End If
End With
Next mySheet
mysheetarray = mysheetarray & """)"
Sheets(mysheetarray).Select
End Sub
Long story short - you are giving a string (mysheetarray) when it is expecting array. VBA likes to get what it expects.
Long story long - this is the way to select all visible sheets:
Option Explicit
Sub SelectAllVisibleSheets()
Dim varArray() As Variant
Dim lngCounter As Long
For lngCounter = 1 To Sheets.Count
If Sheets(lngCounter).Visible Then
ReDim Preserve varArray(lngCounter - 1)
varArray(lngCounter - 1) = lngCounter
End If
Next lngCounter
Sheets(varArray).Select
End Sub
You should define Dim mySheet As Object as Worksheet.
Also, you can use an array of Sheet.Names that are visible.
Code
Sub SelectSheets1()
Dim mySheet As Worksheet
Dim mysheetarray() As String
Dim i As Long
ReDim mysheetarray(Sheets.Count) '< init array to all existing worksheets, will optimize later
i = 0
For Each mySheet In Sheets
If mySheet.Visible = xlSheetVisible Then
mysheetarray(i) = mySheet.Name
i = i + 1
End If
Next mySheet
ReDim Preserve mysheetarray(0 To i - 1) '<-- optimize array size
Sheets(mysheetarray).Select
End Sub
I have tried to explain the Sheets a little, HTH.
Note: Sheets property is defined on Workbook and on Application objects, both works and returns the Sheets-Collection.
Option Explicit
Sub SheetsDemo()
' All sheets
Dim allSheets As Sheets
Set allSheets = ActiveWorkbook.Sheets
' Filtered sheets by sheet name
Dim firstTwoSheets As Sheets
Set firstTwoSheets = allSheets.Item(Array("Sheet1", "Sheet2"))
' or simply: allSheets(Array("Sheet1", "Sheet2"))
' Array("Sheet1", "Sheet2") is function which returns Variant with strings
' So you simply need an array of sheet names which are visible
Dim visibleSheetNames As String
Dim sh As Variant ' Sheet class doesn't exist so we can use Object or Variant
For Each sh In allSheets
If sh.Visible Then _
visibleSheetNames = visibleSheetNames & sh.Name & ","
Next sh
If Strings.Len(visibleSheetNames) > 0 Then
' We have some visible sheets so filter them out
visibleSheetNames = Strings.Left(visibleSheetNames, Strings.Len(visibleSheetNames) - 1)
Dim visibleSheets As Sheets
Set visibleSheets = allSheets.Item(Strings.Split(visibleSheetNames, ","))
visibleSheets.Select
End If
End Sub
I keep getting a type mismatch error and have tried changing the type a few times. I'm just trying to loop through each worksheet and a specified range to see if that word exists in every cell of that range.
Sub CheckWord()
Dim arrVar As Variant
Dim ws As Worksheet
Dim strCheck As Range
Set arrVar = ActiveWorkbook.Worksheets
'MsgBox (arrVar)
For Each ws In arrVar
If ws.Range("C9:G20").Value = "Word" Then
MsgBox (True)
End If
Next ws
End Sub
When you have a range with many columns, it creates an array.
Taking the array into consideration like so:
Sub CheckWord()
Dim arrVar As Variant
Dim ws As Worksheet
Dim strCheck As Range
Set arrVar = ActiveWorkbook.Worksheets
'MsgBox (arrVar)
For Each ws In arrVar
For each col in ws.Range("C9:G20").Cells
if col.Value = "Word" Then
MsgBox (True)
end if
End If
Next ws
End Sub
You can't get the value of ws.Range("C9:G20") and compare it to one string. You've selected multiple cells. If you want to return True when nay one of these cells contains "Word" or when all of them contain "Word" you'll need to iterate over them.
This is an example of how to return whether or not your range contains "Word" anywhere at least once
Function CheckWord()
Dim arrVar As Variant
Dim ws As Worksheet
Set arrVar = ActiveWorkbook.Worksheets
For Each ws In arrVar
Dim c
For Each c In ws.Range("C9:G20").Cells
If c = "Word" Then
CheckWord = True
Exit Function
End If
Next c
Next ws
End Function
Sub CheckWord()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Range("C9:G20").Find(What:="Word", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) Is Nothing Then MsgBox "Found in " & ws.Name
Next ws
End Sub
I am having problem to solve the error "time execution error #13: incompatible type". If user creates some worksheet that is not stated in the array, it will be deleted. Can anyone help?
sub DeleteNewSheets()
Dim ws, wsP As Worksheet
Dim ArrayOne As Variant
Application.DisplayAlerts = False
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
Set wsP = ThisWorkbook.Worksheets(ArrayOne) ' <--- ERROR #13
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsP.Name Then ws.Delete
Next ws
Application.DisplayAlerts = True
end sub
Your line of code saying:
Set wsP = ThisWorkbook.Worksheets(ArrayOne)
is trying to set a Worksheet object to an array of many Worksheets. That's like trying to set a single Integer to be an array of Integers.
Try using the following code
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne() As Variant
Dim wsName As Variant
Dim Matched As Boolean
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
Matched = False
For Each wsName In ArrayOne
If wsName = ws.Name Then
Matched = True
Exit For
End If
Next
If Not Matched Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
End Sub
If you add an extra For ... Next or For Each ... Next statement to loop through every element in ArrayOne and conditional IFs statement then it should do the work. So your code should be like this
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne As Variant, iSheet As Integer
Application.DisplayAlerts = False
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
For Each ws In ThisWorkbook.Worksheets
For iSheet = LBound(ArrayOne) To UBound(ArrayOne)
If ws.Name = ArrayOne(iSheet) Then Exit For
If iSheet = UBound(ArrayOne) Then
ws.Delete
End If
Next
Next
Application.DisplayAlerts = True
End Sub
or alternatively
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne As Variant
Application.DisplayAlerts = False
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
For Each ws In ThisWorkbook.Worksheets
For Each Element In ArrayOne
If ws.Name = Element Then Exit For
If Element = ArrayOne(UBound(ArrayOne)) Then
ws.Delete
End If
Next
Next
Application.DisplayAlerts = True
End Sub
you can check sheets in one loop and delete "bad" ones in one shot as follows:
Option Explicit
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim sheetsToDelete As String
Const GOODSHEETS As String = "\SheetA\SheetB\SheetC\Sheet_n\" '<--| list of good sheets names, separated by an invalid character for sheet names
For Each ws In ThisWorkbook.Worksheets
If InStr(GOODSHEETS, "\" & ws.Name & "\") = 0 Then sheetsToDelete = sheetsToDelete & ws.Name & "\" '<--| update sheets to be deleted list
Next ws
If sheetsToDelete <> "" Then '<--| if the list is not empty
sheetsToDelete = Left(sheetsToDelete, Len(sheetsToDelete) - 1) '<--| remove last delimiter ("\") from it
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(Split(sheetsToDelete, "\")).Delete '<-- delete sheets
Application.DisplayAlerts = True
End If
End Sub