I am writing a macro to validate something in each sheet.
If the sheet contains the required info, it's kept, otherwise deleted. But my problem is, once the sheet is deleted focus goes automatically to the next sheet. hence, when the code hits the next sheet it actually skips one sheet in middle.
I have tried the below code :
Sub filterdelete()
Dim current As Workbook
Dim sht As Worksheet
Dim rowN As Integer
Set current = ActiveWorkbook
On Error Resume Next
For Each sht In current.Worksheets
If sht.Name <> "hiddensheet" Then
With sht
.Select
.Range("A1").Select
End With
rowN = Cells(Rows.count, 1).End(xlUp).Row
Application.DisplayAlerts = False
If rowN = 1 Then ActiveSheet.Delete
Application.DisplayAlerts = True
End If
Next sht
End Sub
I tried GoTo, also. But it is deleting every sheet. :(
You have to iterate over the worksheets in your workbook in reverse order so that deleting a sheet does not result in an unwanted behavior.
Try something like this:
For i = current.Worksheets.Count To 1 Step -1
// your code here
Next i
Use a counter variable in your loop and go backwards.
Also, use Long rather than Integer in case you have more rows than latter can handle.
Sub filterdelete()
Dim current As Workbook
Dim sht As Worksheet
Dim rowN As Long, i As Long
Set current = ActiveWorkbook
For i = current.Worksheets.Count To 1 step -1
If current.Sheets(i).Name <> "hiddensheet" Then
With current.Sheets(i)
rowN = .Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
If rowN = 1 Then .Delete
Application.DisplayAlerts = True
End With
End If
Next i
End Sub
Related
I don't really understand VBA, all I can do is paste a code I find that does what I need (thanks to all of your excellent answers to previous questions.) Sometimes I'm able to make simple modifications.
I found a code that's perfect for what I need to do (copy one worksheet to all other sheets), but I need to exclude the first 7 sheets.
The one I'm using already excludes the source sheet, but I haven't been able to figure out how to expand that to include more.
This is the code I'm using:
Dim aWshExcluded As Variant, vWshExc As Variant
aWshExcluded = Array("Exclude(1)", "Exclude(2)")
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Rem Set Source Worksheet
Set WshSrc = ThisWorkbook.Worksheets(2)
Application.ScreenUpdating = 0
Rem Process All Worksheets
For Each WshTrg In WshSrc.Parent.Worksheets
Rem Exclude Worksheet Source
If WshTrg.Name <> WshSrc.Name Then
Rem Validate Worksheet vs Exclusion List
For Each vWshExc In aWshExcluded
If WshTrg.Name = vWshExc Then GoTo NEXT_WshTrg
Next
Rem Process Worksheet Target
With WshTrg.Cells
WshSrc.Cells.Copy
.PasteSpecial Paste:=xlPasteAll 'Everything is pasted.
Application.CutCopyMode = False
Application.Goto .Cells(1), 1
End With: End If:
NEXT_WshTrg:
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = 1
End Sub
Thank you!
Process Worksheets (With Exclusion)
A safer way would be to write the names of the exclusion worksheets to an array and use Application.Match in the loop to find a worksheet name in the array.
Using indexes instead of names is not recommended, e.g. if you move the 2nd worksheet to another position, the code will fail i.e. it will copy the wrong sheet. Also, if you move the main worksheet to a position greater than the ExclusionCount it will be overwritten.
A Quick Fix
Option Explicit
Sub CopySheet()
Const ExclusionsCount As Long = 7
Dim Wbk As Workbook
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim n As Long
Set Wbk = ThisWorkbook
Set WshSrc = Wbk.Worksheets(2)
Application.ScreenUpdating = False ' or 0
For Each WshTrg In Wbk.Worksheets
n = n + 1
If n > ExclusionsCount Then
WshSrc.Cells.Copy
With WshTrg
.Cells.PasteSpecial Paste:=xlPasteAll
Application.Goto .Cells(1), 1
End With
End If
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = True ' or "- 1" in VBA, not "1", although it works.
End Sub
EDIT
The Safer Way
Sub CopySheetWithExclusions()
Const ExclusionsList As String = "Main,Source," _
& "Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday"
Dim Wbk As Workbook
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim Exclusions() As String
Dim n As Long
Set Wbk = ThisWorkbook
Set WshSrc = Wbk.Worksheets("Source")
Exclusions = Split(ExclusionsList, ",")
Application.ScreenUpdating = False
For Each WshTrg In Wbk.Worksheets
If IsError(Application.Match(WshTrg.Name, Exclusions, 0)) Then
WshSrc.Cells.Copy
With WshTrg
.Cells.PasteSpecial Paste:=xlPasteAll
Application.Goto .Cells(1), 1
End With
End If
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = True
End Sub
How do I avoid using select/activate in my macro (to help speed it up)?
The macro goes through each row on a worksheet; if the QTY is greater than zero (in column C), then it calls another macro to open a specific workbook (workbook name in column A), makes some changes and then closes that workbook.
Sub Update_All_Workbooks()
Dim LastRow As Long
Dim DataRange As Range
Dim WB As Workbook
Dim WS As Worksheet
Set WB = ActiveWorkbook
Set WS = ActiveSheet
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set DataRange = Sheets("TestA").Range("A3:A" & LastRow)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
WB.Sheets("TestA").Activate
Range("C3").Select
For Each Row In DataRange
If ActiveCell > 0 Then
Call Open_Update_Close_WB
WB.Sheets("TestA").Activate
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Next Row
WS.Activate
End Sub
Its quite a change in perspective to move from using select to using references but in the long run, code is much better when using references.
I hop the code below is useful to you.
Option Explicit
Sub Update_All_Workbooks()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim myWB As Workbook
Set myWB = ActiveWorkbook
' We set myWS on the basis of the unqualified Cell method used in th original code
Dim myWS As Worksheet
Set myWS = myWB.ActiveSheet
Dim LastRow As Long
LastRow = myWS.Cells(Rows.Count, "A").End(xlUp).Row
' Pull the filenames into a VBA array
' So we don't keep having to refder to a Worksheet
' The transpose method is used to convert the pseudo 2D array
' to a correct 1D array
Dim myWbNames As Variant
Set myWbNames = myWB.Application.WorksheetFunction.Transpose(myWS.Range("A3:A" & LastRow).Value)
' Similar to above, you can extract the QTY values in
' column C to a VBA array
Dim myQTY As Variant
Set myQTY = myWB.Application.WorksheetFunction.Transpose(myWS.Range("C3:C" & LastRow).Value)
' Because we are processing two arrays (col a and col c)
' its easier to use a standard for loop with an index than a for each loop
Dim myIndex As Variant
For myIndex = LBound(myWbNames) To UBound(myWbNames)
If myQTY(myIndex) > 0 Then
Open_Update_Close_WB myWbNames(myIndex)
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
' Underscores have significance in Method names as they are used in
' interface and event declarations
' Therefore it is good practise to get used to NOT using underscores
' for Method names that do not involve an interface
Public Sub OpenUpdateCloseWB(ByVal ipWbName As String)
End Sub
Sorry for the oddly worded question. I have code (below) that creates new sheets based on column data. After the sheets are created VBA copies and pastes every row from the master sheet into the category sheet. I just want excel to save the .csv file and close. It closes but only keeps the last sheet. Is this due to it being a .csv file? If I manually Save As and convert to .xlsx then the columns remain. But I tried adding VBA code to do the same thing and it just saved an empty .xlsx file. I'm not sure what to do...
Sub Loading_Summary_Breakout()
'Prevents Clipboard Pop-up from appearing.
Application.DisplayAlerts = False
'Prevents screen flicker and makes the macro run faster.
Application.ScreenUpdating = False
'Opens Loading Summary workbook.
Workbooks.Open Filename:=Environ("USERPROFILE") & "\Dropbox (Gotham Enterprise)\Operations Management\#MASTER SCHEDULE\Shop Schedule V4\Loading Summary.csv"
Workbooks("Loading Summary.csv").Activate
Call DeleteRowsSpecialChartrs
Dim cell As Range, v
Dim SheetName As String, wb As Workbook, ws As Worksheet
Set ws = ActiveSheet
Set wb = ws.Parent
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In ws.Range(ws.Range("B2"), ws.Range("B" & Rows.Count).End(xlUp)).Cells
v = cell.Value
If Len(v) > 0 Then cell.EntireRow.Range("A1:O1").Copy _
GetSheet(v, wb).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
Call DeleteDuplicates
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
'Return a named sheet in wb (or create if doesn't exist)
Private Function GetSheet(ByVal SheetName As String, wb As Workbook)
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = SheetName
End If
Set GetSheet = ws
End Function
Public Sub DeleteRowsSpecialChartrs()
Dim rng As Range
Dim pos As Integer
Set rng = ActiveSheet.Range("B:B")
For i = rng.Cells.Count To 1 Step -1
pos = InStr(LCase(rng.Item(i).Value), LCase("/"))
If pos > 0 Then
rng.Item(i).EntireRow.Delete
End If
Next i
End Sub
Public Sub DeleteDuplicates()
Dim ws As Worksheet
Dim wkbk1 As Workbook
Dim w As Long
Set wkbk1 = Workbooks("Loading Summary.csv")
wkbk1.Activate
With wkbk1
For w = 1 To .Worksheets.Count
With Worksheets(w)
.Range("A:O").RemoveDuplicates Columns:=1, Header:=xlYes
End With
Next w
End With
End Sub
I wonder what the text in this message means...
I's the text you see when you 'Save As'/'CSV'.
I have a problem with my code whereby everything works fine except one line that keeps getting the automation error even though the sheet exists. My code is supposed to delete sheets based on a certain name column and despite editing it, the error still occurs. Would appreciate if someone could help me out here, thanks!
Sub DeleteSelectedSheets()
Const lngNameCol = 8 ' names in column (H)
' lngRow = 5 ' data start in row 5
Dim i As Long
Dim lastrow As Long
Dim row_num As Long
Dim wsh_to_delete As Worksheet
Dim main_sheet As Worksheet
Dim ws As Worksheet
Set main_sheet = ActiveSheet
lastrow = main_sheet.Range("A" & main_sheet.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
For row_num = 5 To lastrow
If Not ws Is Nothing Then
If ws.Name = main_sheet.Cells(row_num, lngNameCol).Value Then
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(ws.Name).Delete
Application.DisplayAlerts = True
On Error GoTo 0
End If
End If
Next
Next
End Sub
The automation error occurs here:
If ws.Name = main_sheet.Cells(row_num, lngNameCol).Value Then
Although the code deleted the sheets, the error keeps popping out after every row
I think the problem lies in the deletion of the worksheet during the loop.
Try your loops the other way around, cycling through each sheet to see if it is the name you're looking for:
For row_num = 5 To lastrow
For Each ws In ActiveWorkbook.Worksheets
If Not ws Is Nothing Then
If ws.Name = main_sheet.Cells(row_num, lngNameCol).Value Then
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(ws.Name).Delete
Application.DisplayAlerts = True
On Error GoTo 0
End If
End If
Next
Next
When you delete element from a collection, the whole collection is a bit "unhappy". With the worksheets, the best way is to loop from the total count of the worksheets to 1 and check whether your worksheet should be deleted:
Sub TestMe()
Dim i As Long
For i = Worksheets.Count To 1 Step -1
If Worksheets(i).Name = "Something" And Worksheets.Count > 1 Then
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
End If
Next
End Sub
Additionally, there is a rule for Worksheets.Count>1, because the last worksheet of the workbook cannot be deleted.
I have an Excel workbook that has the potential for a large number of sheets to be added in or removed. Each of these will have a standard suffix, let's call this ".A"
What I would like is a macro that for each worksheet with this suffix, copies all data from a selected range on each worksheet (say:A1:X50), copies it to a new consolidated worksheet, moves to the next line on the consolidated sheet and repeats for each subsequent worksheet. So far, I have this... but it doesn't work.
Sub compile()
SelectSheets ".A", ThisWorkbook
'Some other bits and pieces here
End Sub
Sub SelectSheets(sht As String, Optional wbk As Workbook)
Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long
If wbk Is Nothing Then Set wbk = ActiveWorkbook
ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
If InStr(1, wks.Name, sht) > 0 Then
ArrWks(i) = wks.Name
i = i + 1
End If
Next wks
ReDim Preserve ArrWks(i - 1)
Sheets(ArrWks).Select
For Each ws In Sheets(ArrWks)
ws.Range("D36:CT46").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
There are other changes i would make to this code but the basics are as follows; where you loop the array containing the worksheet names and do your copying.
Note:
1) You are picking up any worksheet name with .A in, not just those with it as a suffix.
2) You might also want some error handling in case no sheets are found as then your array will end up throwing an out of bounds error.
3) Your first paste will be to row 2 if you don't test if last row = 1.
Looping of array:
For ws = LBound(ArrWks) To UBound(ArrWks)
A test for the suffix might better be
If Right$(wks.Name, 2) = ".A" Then
Code:
Option Explicit
Sub compile()
SelectSheets ".A", ThisWorkbook
'Some other bits and pieces here
End Sub
Sub SelectSheets(sht As String, Optional wbk As Workbook)
Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long
If wbk Is Nothing Then Set wbk = ActiveWorkbook
ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
If InStr(1, wks.Name, sht) > 0 Then
ArrWks(i) = wks.Name
i = i + 1
End If
Next wks
ReDim Preserve ArrWks(i - 1)
Dim ws As Long
For ws = LBound(ArrWks) To UBound(ArrWks)
Worksheets(ArrWks(ws)).Range("D36:CT46").Copy
Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub