One of the modules in a larger project is creating redundant veryHidden sheets. I am attempting to loop through every worksheet in the workbook and delete sheets that are marked as veryHidden. I've used almost identical code in other projects and it has worked so I am unsure why it is not working in this situation. Here is what I've tried:
Dim sheet As Worksheet
For Each sheet In ActiveWorkbook.Worksheets
If sheet.Visible = xlSheetVeryHidden Then
sheet.Delete
End If
Next sheet
I've also tried that same code using:
For Each sheet In ActiveWorkbook
And I've also tried:
Dim i As Integer
Dim sheetCount As Integer
For i = 1 To sheetCount
If Worksheets(i).Visible = xlVeryHidden Then
Worksheets(i).Delete
End If
Next i
And also:
For i = sheetCount To 3 Step -1
If Worksheets(i).Visible = xlVeryHidden Then
Worksheets(i).Delete
End If
Next i
In all attempts Application.DisplayAlerts is changed to False before running and changed to True after running. Results in run-time error 1004.
If you unhide the sheet before deleting it, it should work.
Dim sheet As Worksheet
For Each sheet In ActiveWorkbook.Worksheets
If sheet.Visible = xlSheetVeryHidden Then
sheet.visible = xlSheetVisible
sheet.Delete
End If
Next sheet
Related
I have a macro that generates a lot of worksheets and charts. There's also various subroutines that run so the names and quantity of each worksheet/chart generated is never the same. What is constant is my HOME worksheet which is the UI for the user and I want it to be unaffected.
I found a similar question here about deleting all worksheets except the one you are working with (i.e. HOME). Here's what I have so far.
Sub ZRESET()
Dim ws As Worksheet, wb As Workbook
Set wb = ActiveWorkbook
Sheets("HOME").Select
Application.DisplayAlerts = False
For Each ws In wb.Worksheets
If ws.Name <> "HOME" Then
ws.Delete
End If
If Chart.Name = "" Then
Charts.Delete
End If
Next
Application.DisplayAlerts = True
Range("B5:E5,B9:E9,B13:E13,B14:E14").ClearContents
Range("A1").Select
End Sub
The worksheets delete fine, the hang up I have is the charts. I tried various attempts to remove charts and sometimes they work (i.e placing Charts.Delete outside of a FOR loop and IF statement). But this requires me to actually have a chart in the workbook. Sometime the user can just develop worksheets but no charts.
Any advice to continue my goal of deleting SHEETS and/or CHARTS, while keeping my HOME sheet intact?
Option Explicit
Sub GetRid()
Dim ASheet As Worksheet
Dim AChart As Chart
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'** first scan for and delete all non HOME worksheets ***
For Each ASheet In ActiveWorkbook.Worksheets
If UCase(ASheet.Name) <> "HOME" Then
ASheet.Delete
End If
Next
'** Now scan and delete any ChartSheets ****
For Each AChart In ActiveWorkbook.Charts
AChart.Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub AllSheetsAndcharts()
Dim AChart As ChartObject
Dim ASheet As Worksheet
Application.DisplayAlerts = False
For Each ASheet In ActiveWorkbook.Worksheets
If UCase(ASheet.Name) <> "HOME" Then
For Each AChart In ASheet.ChartObjects
AChart.Delete
Next
ASheet.Delete
End If
Next
Application.DisplayAlerts = False
End Sub
I recently asked a question and received a great answer on this site, but I am now running into a different problem. The code below works well for running through each workbook in a folder, copying a sheet's contents, and pasting those contents into a master workbook exactly how I would like:
Sub ConslidateWorkbooks()
'Code to pull sheets from multiple Excel files in one file directory
'into master "Consolidation" sheet.
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim wbName As String
With ActiveSheet
Range("A1").Activate
End With
Application.ScreenUpdating = False
FolderPath = ActiveWorkbook.Path & "\"
Filename = Dir(FolderPath & "*.xls*")
wbName = ActiveWorkbook.Name
Do While Filename <> ""
If Filename <> wbName Then
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
copyOrRefreshSheet ThisWorkbook, Sheet
Next Sheet
Workbooks(Filename).Saved = True
Workbooks(Filename).Close
ActiveSheet.Range("A1").Activate
End If
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
End Sub
The problem I am having now: After the paste is completed, each sheet in the master workbook has all of its cells selected, as though I Ctrl+A'd the entire sheet. I would like to get rid of this. It is a small task which I tried to accomplish in the line ActiveSheet.Range("A1").Activate within the Do While .. loop, but it has not worked for me.
EDIT:
I found a solution that works in this case. I am not sure why this was necessary, because the comments and answers in this thread seem like they should work, but they did not. I call this sub before I turn screenupdating to True in the main sub:
Sub selectA1()
Worksheets(1).Activate
Dim Sheet As Worksheet
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Sheet.Range("A1").Select
Next Sheet
Worksheets(1).Activate
End Sub
I realize this is more complicated than it should be, but it works for my purposes.
In your copy sub, add in another code in the loop that will select a cell which should deactivate the total used range selection and just select the coded range.
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
ws.range("A1").select
Application.CutCopyMode = False
End If
End Sub
I added ws.range("A1").select which should do as I described above.
I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub
I am needing to copy cells B3:W400 from multiple sheets (will have varying names each time it is run) and paste values into "CombinedPlans", appending each new selection under the last. I need 3 sheets excluded from the code: IBExport, MonthlyIBs, and Combined Plans.
A lot of googling with trial and error has given me the following code, which I got to work in my "practice" workbook. Now that I have put it into my production workbook, it is no longer copying any sheets. It just skips straight to the message box. What am I doing wrong?
Sub consolidatetest()
Sheets("CombinedPlans").Select
Range("B3:W1048576").Select
Selection.ClearContents
Dim J As Integer
Dim sh As Worksheet
Const excludeSheets As String = "QBExport,MonthlyIBs,CombinedPlans"
On Error Resume Next
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, Split(excludeSheets, ","))) Then
Application.GoTo Sheets(sh.Name).[b3]
Range("B3:W400").Select
Selection.Copy
Worksheets("CombinedPlans").Activate
Range("B1048576").End(xlUp).Offset(rowOffset:=1, columnOffset:=0).PasteSpecial xlPasteValues
End If
Next
Application.CutCopyMode = False
MsgBox "Complete!"
End Sub
This should work. If you have still problems, make sure that the Sheet CombinedPlans is indeed so named.
Sub consolidatetest()
Dim wb As Workbook
Dim sh_CombPlans As Worksheet
Set wb = ThisWorkbook
Set sh_CombPlans = wb.Sheets("CombinedPlans")
sh_CombPlans.Range("B3:W1048576").ClearContents
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case "QBExport", "MonthlyIBs", "CombinedPlans":
'Do Nothing
Case Else
sh.Range("B3:W400").Copy
sh_CombPlans.Range("B1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End Select
Next
Application.CutCopyMode = False
MsgBox "Complete!"
End Sub
I want to copy data from each tab in a spreadsheet and save it as new workbooks. The original workbook has many tabs (approx 50) and one of these tabs set up for the macro to run data from, as there may be new tabs added in the future. The macro data tab contains the file location for each new workbook, the name of the tab and also some information used by another macro to e-mail these newly created workbooks to relevant parties.
The issue is getting the macro to recognize the tab names for finding the range to copy, as the tab names are listed in a cell. I am unsure if it is possible to use this list, or whether I add a sheet at the end to loop through all the sheets from a specified start location until that one with an if.
Sub Datacopy()
Dim ws As Worksheet
With Application
.ScreenUpdating = False
End With
Application.DisplayAlerts = False
Set ws = Sheets("email")
For Each Cell In ws.Columns("B").Cells
Dim file1 As String
file1 = Cell.Offset(0, 3).Text
Sheets("cell.value").Range("A1:L500").Copy
Workbooks.Add.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme)
Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteComments)
ActiveWorkbook.SaveAs Filename:=file1
ActiveWorkbook.Close
Next Cell
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
End With
MsgBox ("Finished making files!")
End Sub
Something like this should work for you. Note the following:
Code assumes that on sheet "email" it has a header row which is row 1 and the actual data starts on row 2.
It checks to see if the B column cell is a valid worksheet name in the workbook
I have verified that this code works properly and as intended based on your original post:
Sub Datacopy()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsTemp As Worksheet
Dim rSheetNames As Range
Dim rSheet As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("email")
Set rSheetNames = wsData.Range("B2", wsData.Cells(Rows.Count, "B").End(xlUp))
If rSheetNames.Row < 2 Then Exit Sub 'No data
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each rSheet In rSheetNames
If Not Evaluate("ISERROR('" & rSheet.Text & "'!A1)") Then
Set wsTemp = Sheets.Add
Sheets(rSheet.Text).Range("A1:L500").Copy
wsTemp.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
wsTemp.Range("A1").PasteSpecial xlPasteComments
wsTemp.Move
ActiveWorkbook.SaveAs rSheet.Offset(, 3).Text
ActiveWorkbook.Close False
End If
Next rSheet
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Finished making files!"
End Sub