I'm trying to loop through sheets, and remove row entries that are not equal to sheet name.
I've if statements to ignore particular sheets.
It will only work on one sheet and won't loop through all.
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
With ws
For Each ws In ActiveWorkbook.Worksheets
If ActiveSheet.Name = "Raw Data" Then
ElseIf ActiveSheet.Name = "Building Status" Then
ElseIf ActiveSheet.Name = "Clean Data" Then
Else
For lngx = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(lngx, "A").Value <> ActiveSheet.Name Then
Cells(lngx, "A").EntireRow.Delete Shift:=xlUp
End If
Next
End If
Next
End With
End Sub
Updated code, still not working:
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Raw Data" Then
ElseIf ws.Name = "Building Status" Then
ElseIf ws.Name = "Clean Data" Then
Else
For lngx = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(lngx, "A").Value <> ws.Name Then
Cells(lngx, "A").EntireRow.Delete Shift:=xlUp
End If
Next
End If
Next
End Sub
You are missing the ws object. Try this (you also forgot to enable ScreenUpdate at the end):
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
For Each ws In ActiveWorkbook.Worksheets
Select Case ws.Name
Case "Raw Data", "Building Status", "Clean Data"
Case Else
With ws
For lngx = .Cells(.Rows.Count, "A").End(xlUp).Row To 3 Step -1
If .Cells(lngx, "A").Value <> .Name Then
.Rows(lngx).Delete Shift:=xlUp
End If
Next
End With
End Select
Next
Application.ScreenUpdating = True
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
Kindly advice how to stop macro automatically from running when it reach last sheet, as I get run time error at the end
Sub ACT1()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Application.ScreenUpdating = False
Range("B:B").Select
With Selection
.NumberFormat = "General"
.Value = .Value
.HorizontalAlignment = xlLeft
End With
Sheets(ActiveSheet.Index + 1).Activate
Debug.Print ws.Name
Next ws
End Sub
I have try to use
If folder.Show <> -1 Then Exit Sub
but It do not help
Try this. Your code fails because you are trying to activate the next worksheet from the current one so when you get to the end, there is no more sheets to activate.
Sub ACT1()
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
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
I want to delete all the sheets in the workbook except month end sheets for a given year eg of sheet names all sheet names are entered in this format dd.mm.yy
I tried other codes like case instead of If but all codes seems to stop at ws.delete
Sub Delete_Sheets
Yr = InputBox("Use YY format only.", "Which year to keep?", 18)
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "31.01.Yr" Or ws.Name <> "28.02.Yr" Or ws.Name <> "31.03.Yr" Or ws.Name <> "30.04.Yr" Or ws.Name <> "31.05.Yr" Or ws.Name <> "30.06.Yr" Or ws.Name <> "31.07.Yr" Or ws.Name <> "31.08.Yr" Or ws.Name <> "30.09.Yr" Or ws.Name <> "31.10.Yr" Or ws.Name <> "30.11.Yr" Or ws.Name <> "31.12.Yr" Then
ws.Delete
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Use Application.InputBox method instead of InputBox only. This one has a Type:=1 parameter that forces the user to enter numbers only.
Make sure you test for ThisWorkbook.Worksheets.Count > 1 because you cannot delete the last worksheet. At least 1 worksheet must remain.
Put all the sheets you want to skip into an array SkipSheets and filter that array for your worksheet name (UBound(Filter(SkipSheets, ws.Name)) > -1)
Option Explicit
Public Sub DeleteSheets()
Dim InputYear As Variant
InputYear = Application.InputBox(Prompt:="Use YY format only.", Title:="Which year to keep?", Default:=18, Type:=1)
If VarType(InputYear) = vbBoolean And InputYear = False Then Exit Sub 'user pressed cancel
Dim SkipSheets() As Variant
SkipSheets = Array("31.01." & InputYear, "28.02." & InputYear, "31.03." & InputYear, "30.04." & InputYear, "31.05." & InputYear, "30.06." & InputYear, "31.07." & InputYear, "31.08." & InputYear, "30.09." & InputYear, "31.10." & InputYear, "30.11." & InputYear, "31.12." & InputYear)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not (UBound(Filter(SkipSheets, ws.Name)) > -1) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This is another approach. Since you don't want to delete the last day of every month and looks like all the sheets are the same:
Option Explicit
Sub Delete_Sheets()
Dim ws As Worksheet, Month As Date, DontDelete As String, Yr As Integer
StartAgain:
On Error Resume Next
Yr = InputBox("Use YY format only.", "Which year to keep?", 18)
On Error GoTo 0
If Yr = 0 Then
MsgBox "You didn't enter a valid value. Please Try Again"
GoTo StartAgain
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name Like "??.??.??" And ThisWorkbook.Sheets.Count > 1 Then
ws.Delete
GoTo NextSheet
End If
Month = DateSerial(Yr, Mid(ws.Name, 4, 2), 1)
DontDelete = Format(Application.EoMonth(Month, 0), "dd.mm.yy")
If Not ws.Name = DontDelete Then
ws.Delete
End If
NextSheet:
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Edit: I've edited some code but it can't throw any error. Now it shouldn't delete some worksheet that it did. But there is no way you get an error.
Here is the result of the code:
I have three macros in my workbook that work fine. However, when I protect any of the worksheets, they stop to work and I get a run-time error 1004.
I have tried following the two suggestions that I found online:
Unprotect at start of macro code, and protect at end;
User Interface Only) but the run-time error remains.
I need my Workbook to be protected and for my macros to function, what shall I do?
Macro 1:
Sub Macro1()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Visit & Order Database")
'check for duplicate order ID in database
If inputWks.Range("CheckID2") = True Then
lRsp = MsgBox("Clinic ID already in database. Update database?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Clinic ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry2")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
myCopy.Copy
.Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End If
End Sub
Macro 2
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Contact Details & Segm Database")
'check for duplicate order ID in database
If inputWks.Range("CheckID") = True Then
lRsp = MsgBox("Clinic ID already in database. Update database?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Clinic ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
myCopy.Copy
.Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(52) ', Scroll:=True
End With
On Error GoTo 0
End With
End If
End Sub
Macro 3
Sub UpdateLogRecord()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim lRec As Long
Dim oCol As Long
Dim lRecRow As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Contact Details & Segm Database")
'check for duplicate order ID in database
If inputWks.Range("CheckID") = False Then
lRsp = MsgBox("Clinic ID not in database. Add clinic to database?", vbQuestion + vbYesNo, "New Order ID")
If lRsp = vbYes Then
UpdateLogWorksheet
Else
MsgBox "Please select Clinic ID that is in the database."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry")
lRec = inputWks.Range("CurrRec").Value
lRecRow = lRec + 1
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(lRecRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(lRecRow, "B").Value = Application.UserName
oCol = 3
myCopy.Copy
.Cells(lRecRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With myCopy.Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(52) ', Scroll:=True
End With
On Error GoTo 0
End With
End If
End Sub
You don't have any code in there to unprotect at the start of the macro and then protect again at the end. You need something like this at the start (I think you already know this but just trying to be clear).
SheetName.Unprotect Password:=yourPassword
And this at the end:
SheetName.Protect Password:=yourPassword
You say you've tried this already but it's not clear from the code you posted where you had these commands.
From trying to reproduce the behaviour at this end I notice you have two different worksheets you refer to as historyWks which could be causing problems with locking and unlocking.
One option is to unprotect all worksheets at your entry point then protect them again at the exit.
Private Const yourPassword As String = "password"
Sub UnprotectAll()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect Password:=yourPassword
Next sh
End Sub
Sub ProtectAll()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Protect Password:=yourPassword
Next sh
End Sub
You just need to call these at the start and end of your Macro1. You might also want to add an Application.ScreenUpdating = False at the start to avoid flicker as it loops through all the worksheets and then Application.ScreenUpdating = True at the end of Macro1.
help for macro beginners:
if you are using a button to run a macro,
include the following inside sub buttonclick()
Dim sh As Worksheet
Dim yourPassword As String
yourPassword = "whatever password you like"
For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect Password:=yourPassword
"now enter your macro which needs to be run
,at the end , before end sub paste the below line
For Each sh In ActiveWorkbook.Worksheets
sh.Protect Password:=yourPassword
Next sh