I made a code that would delete Worksheets if range "D14:K70" is empty throughout the workbook but I do not know how to ignore "-----------" which are in the worksheet range 72x and empty spaces are 368x. Also I am having an issue at Sheets(i).Delete
Sub DeletingEmptyPages()
Dim i As Long
For i = Sheets.count To 1 Step -1
If WorksheetFunction.CountIf(Sheets(i).Range("D14:K70"), "") >= 368 Then
If Sheets.count > 1 Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
Else
MsgBox "Only 1 sheet left"
Exit Sub
End If
End If
Next i
End Sub
A slightly different way of approaching the same issue. You could add in a do whole loop to stop if it find something as it will speed up the process slightly but the range is so small I don't think it will be an issue.
Sub DeletingEmptyPages()
Dim i As Long
Dim strTestRange As String
Dim bDeleteSheet As Boolean
strTestRange = "D14:K70"
For Each ws In ThisWorkbook.Worksheets
bDeleteSheet = True
For Each c In ws.Range(strTestRange)
If Not (c.Value = "" Or c.Value = "-") Then bDeleteSheet = False
Next c
If bDeleteSheet Then
If Sheets.Count > 1 Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Else
MsgBox "Only 1 sheet left"
Exit Sub
End If
End If
Next ws
End Sub
Sub DeletingEmptyPages()
Dim i As Long
For i = Sheets.count To 1 Step -1
If WorksheetFunction.CountA(Sheets(i).Range("D14:K25, D27:K27, D29:K31, D34:K34, D36:K52, D55:K55, D57:K57, D59:K66, D68:K68, D70:K70 "), "") >= 368 Then
If Sheets.count > 1 Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
Else
MsgBox "Only 1 sheet left"
Exit Sub
End If
End If
Next i
End Sub
Related
I am trying to look through data that a user has selected in a listbox, when the user clicks "Reserve offcuts" then all the selected lines of data that I have copied over on sheet "Offcut Basket" is then placed onto the database worksheet which is labled as "wo2" I want my code to then look through each line of column E and if that ID matches the ID on the database sheet it will then input the value as "Snumber" which is the value which is captured from the textbox on the userform in the column next to the ID
my Problem is that my code that looks through each cell is asking for an object, I see that i need to declare the objects meaning on which sheet i need to look through, but just a better understanding of where i have put my loop will be a great help. Thanks everyone
Private Sub CommandButton11_Click()
'Reserve offcuts with job number
If Offcut11.OffcutJob.Value = "" Then
MsgBox "Please insert SAGE job number!", vbExclamation, "JDS"
Exit Sub
End If
Dim snumber As String
snumber = Offcut11.OffcutJob.Value
Dim wo1 As Workbook
Dim wo2 As Workbook
Set wo1 = Workbooks("Fabrication Schedule v2")
Do
Set wo2 = Workbooks.Open(Filename:="J:\Database\Offcut Database.xlsx")
If wo2.ReadOnly Then Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until Not wo2.ReadOnly
Application.Visible = False
Application.ScreenUpdating = False
wo1.Activate
Sheets("Offcut Basket").Activate
Range("A2:F200").Copy
wo2.Activate
Sheets("Offcut Basket").Activate
Range("A1").PasteSpecial xlPasteValues
Dim acr As String
Dim v As Range
Set v = Worksheets("Offcut Basket").Cells(Worksheets("Offcut Basket").Rows.Count, "E").End(xlUp)
With Worksheets("Offcut Database")
For Each cell In .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp))
If Int(cell.Value2) = Int(r.Value2) Then
Cells(v.Row, 2).Select
acr = ActiveCell.Row
Cells(acr, "F").Value = snumber
End If
Next cell
End With
Application.DisplayAlerts = False
wo2.Save
wo2.Close
wo1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Offcuts have been reserved", vbExclamation, "JDS"
End Sub
I figured it out,
Private Sub CommandButton11_Click()
'Reserve offcuts with job number
If Offcut11.OffcutJob.Value = "" Then
MsgBox "Please insert SAGE job number!", vbExclamation, "JDS"
Exit Sub
End If
Dim snumber As String
snumber = Offcut11.OffcutJob.Value
Dim wo1 As Workbook
Dim wo2 As Workbook
Set wo1 = Workbooks("Fabrication Schedule v2")
Do
Set wo2 = Workbooks.Open(Filename:="J:\Database\Offcut Database.xlsx")
If wo2.ReadOnly Then Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until Not wo2.ReadOnly
Application.Visible = False
Application.ScreenUpdating = False
wo1.Activate
Sheets("Offcut Basket").Activate
Range("A2:F200").Copy
wo2.Activate
Sheets("Offcut Basket").Activate
Range("A1").PasteSpecial xlPasteValues
Dim acr As String
Dim v As Range
Dim Found As Range
Set v = Sheets("Offcut Basket").Range("E1", Range("E" & Rows.Count).End(xlUp))
For Each cell In v
Sheets("Offcut Database").Activate
Set Found = Sheets("Offcut Database").Range("A2", Range("E" & Rows.Count).End(xlUp)).Find(cell, LookAt:=xlWhole)
Cells(Found.Row, 2).Select
acr = ActiveCell.Row
Cells(acr, "F").Value = snumber
Next cell
Application.DisplayAlerts = False
wo2.Save
wo2.Close
wo1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Offcuts have been reserved", vbExclamation, "JDS"
End Sub
I am running two VBA formulas.
The first hides all cells with empty information the first column.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A49")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A47")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The second Formula strings data together and placeses this information in the next cell that is empty (aka the first hidden cell) when the button is clicked.
Option Explicit
Dim iwsh As Worksheet
Dim owsh As Worksheet
Dim output As String
Dim i As Integer
Sub Copy()
Set iwsh = Worksheets("Budget")
Set owsh = Worksheets("Release Burnup")
i = 3
While owsh.Cells(i, 1) <> ""
i = i + 1
Wend
output = "R" & iwsh.Cells(13, 2).Value & "-S" & iwsh.Cells(14, 2).Value
owsh.Cells(i, 1) = output
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End Sub
Previously, this has been causing no problem... Something has happened that is causing the workbook to crash anytime I try to delete information out of one of the cells with the new data.
PS: This is the list of my other formulas. maybe there is something in these that is interacting with the formentioned code?
Private Sub NewMemberBut_Click()
'causes userform to appear
NewMember.Show
'reformats button because button kept changing size and font
NewMemberBut.AutoSize = False
NewMemberBut.AutoSize = True
NewMemberBut.Height = 40.25
NewMemberBut.Left = 303.75
NewMemberBut.Width = 150
End Sub
'Similar code to the problematic code in question, but this one works fine
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A35,A41:A80")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A35,A41:A80")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
'Code for UserForm
Option Explicit
Dim mName As String
Dim cName As String
Dim mRole As String
Dim cRole As String
Dim i As Integer
Dim x As Integer
Dim Perc As Integer
Dim Vac As Integer
Dim Prj As Worksheet
Dim Bud As Worksheet
Private Sub NewMember_Initialize()
txtName.Value = ""
cboRoleList.Clear
Scrum.Value = False
txtPercent.Value = ""
txtVacation.Value = ""
txtName.SetFocus
End Sub
Private Sub AddMember_Click()
If Me.txtName.Value = "" Then
MsgBox "Please enter a Member name.", vbExclamation, "New Member"
Me.txtName.SetFocus
Exit Sub
End If
If Me.cboRoleList = "Other" And Me.txtCustomRole = "" Then
MsgBox "Please provide a role name.", vbExclamation, "Other Role"
Exit Sub
End If
If Me.cboRoleList.Value = "" Then
MsgBox "Please select a Role.", vbExclamation, "Member Role"
Me.cboRoleList.SetFocus
Exit Sub
End If
If Me.cboRoleList <> "Other" And Me.txtPercent = "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtPercent.Value > 100 And Me.txtPercent <> "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtVacation.Value = "" Then
Me.txtVacation.Value = 0
End If
Dim i As Long
Set Prj = Worksheets("Project Team")
Set Bud = Worksheets("Budget")
Prj.Activate
i = 5
x = 1
If Me.cboRoleList.Value = "Other" Then
i = 46
End If
While Prj.Cells(i, 1) <> ""
i = i + 1
Wend
If cboRoleList = "Other" Then
Cells(i, x).Value = txtCustomRole.Value
End If
If cboRoleList <> "Other" Then
Cells(i, x).Value = cboRoleList.Value
End If
x = x + 1
Cells(i, x).Value = txtName.Value
x = x + 1
If Me.cboRoleList.Value <> "Other" Then
Cells(i, x).Value = txtPercent.Value
End If
Unload Me
End Sub
Private Sub CloseBut_Click()
Unload Me
End Sub
Change the event driven Worksheet_SelectionChange to Worksheet_Change and isolate further by only processing when something changes in A3:A49.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A49")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim c As Range
For Each c In Intersect(Target, Range("A3:A49"))
c.EntireRow.Hidden = CBool(c.Value = vbNullString)
Next c
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Caveat: A Worksheet_Change is not triggered on the change in a cell from the cell's formula. Only by typing, deleting or dragging a cell's contents. Adding or removing a formula will trigger it but not when a formula's result changes from another value somewhere in the workbook changing. This should not affect you as no formula can return vbNullString but it is worth mentioning for others.
This would be a very simple question.
But I am not sure why this is not working in my excel vba code.
Sheets("I- ABC").Select
If IsEmpty(Range("A3").Value) = True And _
IsEmpty(Range("A4").Value) = True And _
IsEmpty(Range("A5").Value) = True And _
IsEmpty(Range("A6").Value) = True Then
Sheets("I- ABC").Delete
End If
What type of error do you get? I tried this code and Excel displays only warning message:
You can avoid this message by adding:
Application.DisplayAlerts = False
and
Application.DisplayAlerts = True
at the beginning and at the end of your code respectively.
--Edited code
Sub Example()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Application.WorksheetFunction.CountA(.Range("A3:A6")) = 0 Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
Try Similiar to This
Sub Test()
Application.DisplayAlerts = False
With Sheets("Sheet1")
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
PS: It works for me and deletes rows containg empty cells in `A:A``
Approach Suggested by #Tim Williams also works for me as per following code in my situation
Sub Test6()
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A3:A6")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
It works even if we use Application instead of WorksheetFunction
If If Application.CountA(Range("A3:A6")) = 0 Then is not working as Tim suggested then that means the cells have blank spaces or unprintable characters.
Try this
Sub Sample()
Dim pos As Long
With Sheets("I- ABC")
pos = Len(Trim(.Range("A3").Value)) + _
Len(Trim(.Range("A4").Value)) + _
Len(Trim(.Range("A5").Value)) + _
Len(Trim(.Range("A6").Value))
If pos = 0 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Else
MsgBox "The cells are not empty"
End If
End With
End Sub
With skkakkar's idea expanded.
Sub Hello()
Dim rng As Range
Application.DisplayAlerts = 0
On Error GoTo er
Set rng = Range("A3:A6").SpecialCells(xlCellTypeConstants, 23)
Exit Sub
er: MsgBox "ActiveSheet.Delete" 'delete sheet
End Sub
If the spaces are the issue, then you can try this code:
Public Sub RemoveIfEmpty()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Trim(.Range("A3") & .Range("A4") & .Range("A5") & .Range("A6")) = "" Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
Stackovwerflow community.
I do believe that this question was asked x1000 times here, but i just wasn not able to find a solution for my slow macro.
This macro serves for unhiding certain areas on worksheets if correct password was entered. What area to unhide depends on cell value. On Sheet1 i have a table that relates certain cell values to passwords.
Here's the code that i use.
1st. Part (starts on userform named "Pass" OK button click)
Private Sub CommandButton1_Click()
Dim ws As Worksheet
DoNotInclude = "PassDB"
For Each ws In ActiveWorkbook.Worksheets
If InStr(DoNotInclude, ws.Name) = 0 Then
Application.ScreenUpdating = False
Call Module1.Hide(ws)
Application.ScreenUpdating = True
End If
Next ws
End Sub
2nd Part.
Sub Hide(ws As Worksheet)
Application.Cursor = xlWait
Dim EntPass As String: EntPass = Pass.TextBox1.Value
If EntPass = Sheet1.Range("G1").Value Then ' Master-Pass, opens all
Sheet1.Visible = xlSheetVisible
ws.Unprotect Password:="Test"
ws.Cells.EntireRow.Hidden = False
Pass.Hide
Else
Dim Last As Integer: Last = Sheet1.Range("A1000").End(xlUp).Row
Dim i As Integer
For i = 2 To Last
Dim region As String: region = Sheet1.Range("A" & i).Value
Dim pswd As String: pswd = Sheet1.Range("B" & i).Value
If EntPass = pswd Then
ws.Unprotect Password:="Test"
ws.Cells.EntireRow.Hidden = False
Dim b As Integer
Dim Last2 As Integer: Last2 = ws.Range("A1000").End(xlUp).Row
For b = 2 To Last2
ws.Unprotect Password:="Test"
If ws.Range("A" & b).Value <> region Then
ws.Range("A" & b).EntireRow.Hidden = True
End If
If ws.Range("A" & b).Value = "HEADER" Then
ws.Range("A" & b).EntireRow.Hidden = False
End If
ws.Protect Password:="Test"
Next b
End If
Next i
End If
Application.Cursor = xlDefault
Sheet2.Activate
Sheet2.Select
Pass.Hide
End Sub
It works fast enough if I enter master-pass to get access to every hidden area, but if i enter cell.value related password, it takes about 5-6 minutes before macro will unhide required areas on every worksheet.
I'd be really grateful if someone could point out the reasons of slow performance and advise changes to be made in code. Just in case, i've uploaded my excel file here for your convenience.
http://www.datafilehost.com/d/d46e2817
Master-Pass is OPENALL, other passwords are "1" to "15".
Thank you in advance and best regards.
Try batching up your changes:
Dim rngShow as Range, c as range
ws.Unprotect Password:="Test" 'move this outside your loop !
For b = 2 To Last2
Set c = ws.Range("A" & b)
If c.Value = "HEADER" Then
c.EntireRow.Hidden = False
Else
If c.Value <> region Then
If rngShow is nothing then
Set rngShow = c
Else
Set rngShow=application.union(c, rngShow)
End If
End If
End If
Next b
If Not rngShow is Nothing Then rngShow.EntireRow.Hidden = False
ws.Protect Password:="Test" 'reprotect...
You might also want to toggle Application.Calculation = xlCalculationManual and Application.Calculation = xlCalculationAutomatic
You can also try moving your Application.Screenupdating code out of the loop, it's going to update for every sheet as written.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Application.ScreenUpdating = False ''<- Here
DoNotInclude = "PassDB"
For Each ws In ActiveWorkbook.Worksheets
If InStr(DoNotInclude, ws.Name) = 0 Then
Call Module1.Hide(ws)
End If
Next ws
Application.ScreenUpdating = True ''<- Here
End Sub
I'm a beginner with VBA and I'm wondering how to add a IF ELSE statement to my code:
I only want to enable to copy the cells if the are filled and if they are not filled msgbox must pop-up
code:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Welcome to stackoverflow.com
You have to wrap your copy code block with a for loop, IF-ELSE statement and a Boolean type variable.
Firstly, you want to iterate over your specified range of cells and make sure they are all filled
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If they are you can proceed with copying-pasting and if they are not the program will show a message box: Not all the cells are filled! Cant copy
your complete code:
Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If allFilled Then ' = if (allFilled = true) then
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp). _
Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
Else
MsgBox "Not all the cells are filled! Cant copy"
End If
End Sub
Update, from comments:
Yes, it's possible to execute different checks individually too, for example:
Dim allFilled As Boolean
If Not IsEmpty(Range("F7, F10, F13, F16")) And IsEmpty(Range("F8")) Then
' F7, F10, F13, F16 are not empty and F8 is empty
allFilled = True
ElseIf IsEmpty(Range("F28")) Then
' F28 empty cannot execute copy-paste
allFilled = False
Else
allFilled = False
End If