There is runtime error 91 on for loop need help!!
Sub clearSheet(WSName As String)
Dim ws As Worksheet
Set ws = Nothing
With ActiveWorkbook
Dim blWSExists As Boolean
blWSExists = False
For i = 1 To .Sheets.Count
If .Sheets(i).Name = WSName Then
blWSExists = True
.Sheets(i).Activate
.Sheets(i).Visible = xlSheetVisible
End If
Next
If Not blWSExists Then
Set ws = .Sheets.Add
ws.Move after:=.Sheets(.Sheets.Count)
ws.Name = WSName
ws.Visible = xlSheetVisible
End If
.Sheets(WSName).AutoFilterMode = False
.Sheets(WSName).Cells.Clear
.Sheets(WSName).UsedRange.ClearOutline
.Sheets(WSName).Cells.ClearFormats
End With
End Sub
Try that:
Dim ws As Worksheet
Dim blWSExists As Boolean
blWSExists = False
For Each ws In Worksheets
If ws.Name = WSName Then
blWSExists = True
End If
Next
If Not blWSExists Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = WSName
End If
Set ws = ActiveWorkbook.Sheets(WSName)
ws.AutoFilterMode = False
ws.Cells.Clear
ws.UsedRange.ClearOutline
ws.Cells.ClearFormats
ws.Activate
You can use Cells.Delete() to clear everything on a Worksheet:
Sub clearSheet(WSName As String)
Dim s As Object
For Each s in ThisWorkbook.Sheets
If s.Name = WSName Then
s.Visible = xlSheetVisible
If TypeOf s Is worksheet Then s.Cells.Delete ' not all Sheets have cells, but all Worksheets do
Exit Sub ' to ignore the rest of the code if the Sheet exists
End If
Next
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = WSName
End Sub
or just delete the sheet and add new to clear absolutely everything associated with the sheet:
Sub clearSheet(WSName As String)
On Error Resume Next
Sheets(WSName).Delete
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WSName
End Sub
Related
Can you you help to combine this 2 code and remove all unnecessary lines to avoid long running time, and I tried to combine it but I get Run time error #9
STEP 1 (Code# 1)
Sub STEP1()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
With ws.Range("B:B")
.NumberFormat = "General"
.Value = .Value
.HorizontalAlignment = xlLeft
End With
Debug.Print ws.Name
Next ws
Application.ScreenUpdating = True
End Sub
STEP 2 (Code# 2)
Sub STEP_2()
Dim ws As Worksheet
For Each ws In Sheets
ws.Cells(1, 1).EntireColumn.Delete
Next ws
Sheets("x_ 659358").Select
Rows("2:3").Select
Selection.Delete Shift:=xlUp
Sheets("x_682549 (2)").Select
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Dim headers() As Variant
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
headers() = Array("sku", "barcode", "active", "price")
For Each ws In wb.Sheets
With ws
.Rows(1).Value = ""
For i = LBound(headers()) To UBound(headers())
.Cells(1, 1 + i).Value = headers(i)
Next i
.Rows(1).Font.Bold = True
End With
Next ws
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.Name, xlCSV
Next
End Sub
I have tried to combine but always get stucked
Sub STEP1()
' your code...
Call STEP_2() ' <----
End Sub
Sub STEP_2()
' your code...
End Sub
I am new to VBA and this is the first Macro I've tried to write.
I have an excel table which has five columns titled Address, location , works , action and completed. I want to create a new worksheet for each unique address and then copy the relevant rows for that address on that new worksheet. However, I only want to copy and paste the unique rows if the value in "Completed" is "N". The Value in completed can only be "Y" or "N".
Here is the code I have written:
Dim AddressField As Range
Dim AddressName As Range
Dim CompletedField As Range
Dim NewWSheet As Worksheet
Dim WSheet As Worksheet
Dim WSheetFound As Boolean
Dim DataWSheet As Worksheet
Set DataWSheet = Worksheets("Data")
Set AddressField = DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown))
Set CompletedField = DataWSheet.Range("E4", DataWSheet.Range("E4").End(xlDown))
Application.ScreenUpdating = False
For Each AddressName In AddressField
For Each WSheet In ThisWorkbook.Worksheets
If CompletedField = "No" Then
If WSheet.Name = AddressName Then
WSheetFound = True
Exit For
Else
WSheetFound = False ' if it doesn't assign False to the WSheetFound variable
End If
Next WSheet
If WSheetFound Then 'if WSheetFound = True
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=Worksheets(AddressName.Value).Range("A3").End(xlDown).Offset(1, 0)
Else 'if WSheetFound = False
Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
NewWSheet.Name = AddressName
DataWSheet.Range("A3", DataWSheet.Range("A3").End(xlToRight)).Copy Destination:=NewWSheet.Range("A3")
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=NewWSheet.Range("A4")
End If
Next AddressName
For Each WSheet In ThisWorkbook.Worksheets
WSheet.UsedRange.Columns.AutoFit
Next WSheet
Application.ScreenUpdating = True
End Sub
I keep getting the "Next without For" error when I try to run the code. I think it has something to do with the "IF CompletedField = "N" line, but not sure how to fix it !
Any help would be greatly appreciated
Try this:
Sub CopyRows()
Dim c As Range, ws As Worksheet, DataWSheet As Worksheet, wb As Workbook
Set wb = ThisWorkbook
Set DataWSheet = wb.Worksheets("Data")
Application.ScreenUpdating = False
For Each c In DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown)).Cells
If c.EntireRow.Columns("E").Value = "No" Then
Set ws = Nothing
On Error Resume Next 'ignore any error on next line
Set ws = wb.Worksheets(c.Value) 'try to get the sheet
On Error GoTo 0 'stop ignoring errors
If ws Is Nothing Then 'was sheet found?
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
DataWSheet.Rows(3).Copy ws.Range("A3") 'copy headers
ws.Name = c.Value 'name the sheet
End If
c.Resize(1, 5).Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next c
For Each ws In wb.Worksheets
ws.UsedRange.Columns.AutoFit
Next ws
Application.ScreenUpdating = True
End Sub
Check the Completed column before deciding if a sheet needs to be created or not.
Update - Added copy for A1,A2,D2
Sub test()
Dim AddressField As Range, AddressName As Range, CompletedField As Range
Dim NewWSheet As Worksheet, WSheet As Worksheet, DataWSheet As Worksheet
Dim WSheetFound As Boolean
Set DataWSheet = Worksheets("Data")
Set AddressField = DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown))
'Set CompletedField = DataWSheet.Range("E4", DataWSheet.Range("E4").End(xlDown))
Application.ScreenUpdating = False
For Each AddressName In AddressField
If AddressName.Cells(1, 5) = "No" Then ' col E
For Each WSheet In ThisWorkbook.Worksheets
If WSheet.Name = AddressName.Value2 Then
WSheetFound = True
Exit For
Else
WSheetFound = False ' if it doesn't assign False to the WSheetFound variable
End If
Next WSheet
If WSheetFound Then 'if WSheetFound = True
AddressName.Offset(0, 0).Resize(1, 5).Copy _
Destination:=Worksheets(AddressName.Value).Range("A3").End(xlDown).Offset(1, 0)
Else 'if WSheetFound = False
Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
NewWSheet.Name = AddressName
DataWSheet.Range("A1:A2").Copy NewWSheet.Range("A1")
DataWSheet.Range("D2").Copy NewWSheet.Range("D2")
DataWSheet.Range("A3", DataWSheet.Range("A3").End(xlToRight)).Copy _
Destination:=NewWSheet.Range("A3")
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=NewWSheet.Range("A4")
End If
End If
Next AddressName
For Each WSheet In ThisWorkbook.Worksheets
WSheet.UsedRange.Columns.AutoFit
Next WSheet
Application.ScreenUpdating = True
End Sub
Not sure why this is failing but for whatever reason, when the ActiveSheet is Console it fails. Going the other way, it works properly. Code is below.
Sub Switch_Books()
Dim ws As Worksheet
protect_book True
If ActiveSheet.Name = "Console" Then
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "CDA Console" Then
ws.Visible = xlSheetVisible
Else
ws.Visible = xlSheetHidden
End If
Next ws
Else
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Console" Then
ws.Visible = xlSheetVisible
Else
ws.Visible = xlSheetHidden
End If
Next ws
End If
protect_book False
End Sub
Try this:
Sub Switch_Books()
Dim ws As Worksheet, wsName
protect_book True 'This is a confusing call...
' you should switch the way the boolean works
wsName = IIf(ActiveSheet.Name = "Console", "CDA Console", "Console")
ThisWorkbook.Sheets(wsName).Visible = xlSheetVisible 'must be at least one sheet visible
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsName Then ws.Visible = xlSheetHidden
Next ws
protect_book False
End Sub
I need to be able to hide all sheets apart from the ones in the array. I have written the code for the array but am now stuck for the rest.
Sub ShowHideWorksheets()
arr = Array("Readme", "Compliance cert", "Cash Balances", "Occupancy Report", "ALPH", "BC", "Bish",
"GC", "HS", "STB", "WOL", "GroupCo", "OpCos", "RCG_ALL")
For Each Value In arr
Next Value
End Sub
Any help will be appreciated.
Hide Worksheets
Option Explicit
Sub hideWorksheets()
Dim arr As Variant
arr = Array("Readme", "Compliance cert", "Cash Balances", _
"Occupancy Report", "ALPH", "BC", "Bish", "GC", "HS", "STB", _
"WOL", "GroupCo", "OpCos", "RCG_ALL")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, arr, 0)) Then
ws.Visible = xlSheetHidden
End If
Next ws
End Sub
Sub showAllWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.Visible = xlSheetHidden Then ws.Visible = xlSheetVisible
Next ws
End Sub
This worked for me
Sub ShowHideWorksheets()
arr = Array("Readme", "Compliance cert", "Cash Balances", "Occupancy Report", "ALPH", "BC", "Bish", "GC", "HS", "STB", "WOL", "GroupCo", "OpCos", "RCG_ALL")
Dim sh As Worksheet, foundSheet As Boolean
For Each sh In Worksheets
For Each Value In arr
If sh.Name = Value Then
foundSheet = True
Exit For
End If
Next Value
If Not foundSheet Then
sh.Visible = xlSheetHidden
End If
foundSheet = False
Next sh
End Sub
I don't know why am getting out of range subscript error. When I click on combobox1 and select an item, MaternityForm combobox is populated with worksheets in my workbook. Then I want to hide other worksheets apart from the one selected in MaternityForm. The active sheet will then receive data from userform but I am getting subscript out of range error..
Private Sub Get_Data_Click()
Dim ws As Worksheet
Dim xWs As Worksheet
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.Visible = True
Next
Set ws = Worksheets(MaternityForm.Value)
Sheets(MaternityForm.Value).Activate
On Error Resume Next
For Each ws In Application.ActiveWorkbook.Worksheets
if ws.Name <> MaternityForm.Value Then
ws.Visible = xlSheetHidden
End If
Next
With Sheets(MaternityForm.Value)
.Range("B3").Value = Me.NameBox.Text
.Range("f3").Value = Me.PaynoBox.Text
.Range("B6").Value = Me.DTPicker1.Value
.Range("B7").Value = Me.DTPicker2.Value
.Range("B17").Value = Me.FirstPayBox.Value
.Range("B18").Value = Me.SecondPayBox.Value
.Range("B25").Value = Me.MonthlyPayBox.Value
.Range("H7").Value = Me.DTPicker3.Value
End With
End Sub
You are confusing your variables ws and xWs.
ws is referring to a specific sheet while xWs is your variable worksheet.
Therefore, your second loop is invalid (This is like saying For Each Sheet1 in Worksheets).
You need to loop through your variable worksheets and compare them to your specific sheet
For Each xWs In Application.ActiveWorkbook.Worksheets
if xWs.Name <> ws.Name Then
xWs.Visible = xlSheetHidden
End If
Next
With that being said, there is no need to loop twice.
Note that ws.Name = MaterityForm.Value will return either TRUE or FALSE. The result of this determines ws.Visible = TRUE/FALSE
Private Sub Get_Data_Click()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
ws.Visible = ws.Name = MaternityForm.Value
Next ws
With Sheets(MaternityForm.Value)
.Range("B3").Value = Me.NameBox.Text
.Range("f3").Value = Me.PaynoBox.Text
.Range("B6").Value = Me.DTPicker1.Value
.Range("B7").Value = Me.DTPicker2.Value
.Range("B17").Value = Me.FirstPayBox.Value
.Range("B18").Value = Me.SecondPayBox.Value
.Range("B25").Value = Me.MonthlyPayBox.Value
.Range("H7").Value = Me.DTPicker3.Value
End With
End Sub