so i used this code
Set Rng = Sheets("COA").Range("i11:i39")
On Error Resume Next
Set VisibleCells = Rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not VisibleCells Is Nothing Then
For Each aCell In VisibleCells
Select Case aCell.DisplayFormat.Interior.Color
Case vbRed
MsgBox "Terdapat data outspek. Periksa kembali!", vbCritical + vbOKOnly, ""
'Show Excel and resize the UserForm2
Application.Visible = True
Me.Height = 405
Me.Width = 730.5
SaveButton.Enabled = False
Case 16777215
Unload UserForm2
'Gets the name of the currently visible worksheet
Filename = "COA" & Sheets("COA").Range("B1")
'Puts the worksheet into its own workbook
ThisWorkbook.ActiveSheet.Copy
'Saves the workbook
ActiveWorkbook.SaveAs Filename
'Closes the newly created workbook so you are still looking at the original workbook
ActiveWorkbook.Close
End Select
Next aCell
End If
If there is a red cell then it will return to the userform. cell I17 is not red, but why is it automatically saved in .xls format? even though if there is a red cell, it cannot be saved in .xls format and must return to the userform. can you guys help me?
Suggest something like this:
Option Explicit
Sub Tester()
Dim rng As Range, Filename As String
Set rng = ThisWorkbook.Sheets("COA").Range("I11:I39")
If HasVisibleRedCell(rng) Then 'call the function to check the range...
MsgBox "Terdapat data outspek. Periksa kembali!", vbCritical + vbOKOnly, ""
Application.Visible = True
Me.Height = 405
Me.Width = 730.5
Me.SaveButton.Enabled = False
Else
Unload UserForm2 'Me?
Filename = "COA" & ThisWorkbook.Sheets("COA").Range("B1")
ThisWorkbook.ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename '<<< should use a full path here...
ActiveWorkbook.Close False
End If
End Sub
'Does the range `rng` contain at least one visible red-filled cell?
Function HasVisibleRedCell(rng As Range) As Boolean
Dim VisibleCells As Range, c As Range
On Error Resume Next
Set VisibleCells = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not VisibleCells Is Nothing Then 'any visible cells?
For Each c In VisibleCells 'check each cell fill
If c.DisplayFormat.Interior.Color = vbRed Then
HasVisibleRedCell = True 'found one
Exit Function 'no need to check further
End If
Next c
End If
'if got here then by default returns False...
End Function
Related
I'm adding a new worksheet to my workbook with
Application.ScreenUpdating = False
SheetExists = False
For Each WS In Worksheets
If WS.Name = "BLANK" Then
SheetExists = True
End If
Next WS
If Not SheetExists Then
Sheets.Add
ActiveSheet.Name = "BLANK"
End If
Is there any way to sheets.add silently without bringing focus to or activating the new added sheet? I just want to stay on the sheet (ie. Sheet1) that is currently active and add the new sheet in the background.
Thanks
At first, things look simple but there are a few things to consider:
There could be more sheets selected before running the code
The selected sheet(s) could be Chart sheet(s)
The Workbook can be protected
You might not want to set Application.ScreenUpdating = True at the end of the method because you might be running this from within another method that still needs it off
Restoring selection can only happen if the proper window is activated
You could use this method:
Sub AddWorksheet(ByVal targetBook As Workbook, ByVal sheetname As String)
Const methodName As String = "AddWorksheet"
'Do input checks
If targetBook Is Nothing Then
Err.Raise 91, methodName, "Target Book not set"
ElseIf sheetname = vbNullString Then
Err.Raise 5, methodName, "Sheet name cannot be blank"
ElseIf Len(sheetname) > 31 Then
Err.Raise 5, methodName, "Sheet name cannot exceed 31 characters"
Else
Dim arrForbiddenChars() As Variant
Dim forbiddenChar As Variant
arrForbiddenChars = Array(":", "\", "/", "?", "*", "[", "]")
For Each forbiddenChar In arrForbiddenChars
If InStr(1, sheetname, forbiddenChar) > 0 Then
Err.Raise 5, methodName, "Sheet name cannot contain characters: : \ / ? * [ or ]"
End If
Next forbiddenChar
End If
Dim alreadyExists As Boolean
'Check if a sheet already exists with the desired name
On Error Resume Next
alreadyExists = Not (targetBook.Sheets(sheetname) Is Nothing)
On Error GoTo 0
If alreadyExists Then
MsgBox "A sheet named <" & sheetname & "> already exists!", vbInformation, "Cancelled" 'Can remove
Exit Sub
End If
'Check if Workbook is protected
If targetBook.ProtectStructure Then
'Maybe write code to ask for password and then unprotect
'
'
'Or simply exit
MsgBox "Workbook is protected. Cannot add sheet", vbInformation, "Cancelled"
Exit Sub
End If
Dim bookActiveWindow As Window
Dim appActiveWindow As Window
Dim selectedSheets As Sheets
Dim screenUpdate As Boolean
Dim newWSheet As Worksheet
'Store state
Set bookActiveWindow = targetBook.Windows(1)
Set appActiveWindow = Application.ActiveWindow 'Can be different from the target book window
Set selectedSheets = bookActiveWindow.selectedSheets
screenUpdate = Application.ScreenUpdating
'Do main logic
screenUpdate = False
If bookActiveWindow.Hwnd <> Application.ActiveWindow.Hwnd Then
bookActiveWindow.Activate
End If
If selectedSheets.Count > 1 Then selectedSheets(1).Select Replace:=True
Set newWSheet = targetBook.Worksheets.Add
newWSheet.Name = sheetname
'Restore state
selectedSheets.Select Replace:=True
If appActiveWindow.Hwnd <> Application.ActiveWindow.Hwnd Then
appActiveWindow.Activate
End If
Application.ScreenUpdating = screenUpdate
End Sub
If you want the book containing the code then you can call with:
Sub Test()
AddWorksheet ThisWorkbook, "BLANK"
End Sub
or, if you want the currently active book (assuming you are running this from an add-in) then you can call with:
Sub Test()
AddWorksheet ActiveWorkbook, "BLANK"
End Sub
or any other book depending on your needs.
Just remember who was active:
Sub ytrewq()
Dim wsh As Worksheet, SheetsExist As Boolean
Set wsh = ActiveSheet
Application.ScreenUpdating = False
SheetExists = False
For Each ws In Worksheets
If ws.Name = "BLANK" Then
SheetExists = True
End If
Next ws
If Not SheetExists Then
Sheets.Add
ActiveSheet.Name = "BLANK"
End If
wsh.Activate
Application.ScreenUpdating = False
End Sub
I have a code which deletes a value from a locked sheet. Whenever I run the code, Error message
Delete method of Range class failed
is displayed. How do I prompt the user with a message such as first unprotect the sheet?
Sub DeleteRow()
Dim rng As Range
On Error Resume Next
With Selection.Cells(1)
Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Please select a valid table cell.", vbCritical
Else
rng.delete xlShiftUp
End If
End With
End Sub
This will Work:
Activesheet.ProtectContents will tell you if a sheet is protected or not.
Sub DeleteRow()
Dim rng As Range
On Error Resume Next
If ActiveSheet.ProtectContents = False Then
With Selection.Cells(1)
Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Please select a valid table cell.", vbCritical
Else
rng.Delete xlShiftUp
End If
End With
Else: MsgBox "Unprotect the Sheet First!"
End If
End Sub
I have my code which loads 2 workbooks, and copies them into a master workbook. However I am getting an
overflow error
when i'm trying to trim all cells in the pasted sheets (too remove the spaces).
Does anyone know why this overflow error would occur when trimming excess blank spaces in a whole sheet? Specifically I am getting the error on this part Target = Target.Value .
Sub Load()
LoadDailyWorkbook
LoadLastWeeksWorkbook
End Sub
Sub LoadDailyWorkbook()
Const A1BJ200 As String = "A1:BJ200"
Const A1L3 As String = "A1:L3"
Dim masterWB As Workbook
Dim dailyWB As Workbook
'Set Current Workbook as Master
Set masterWB = Application.ThisWorkbook
'Set some Workbook as the one you are copying from
Set dailyWB = getWorkbook(Sheets("Control Manager").Range("O2"))
If Not dailyWB Is Nothing Then
With dailyWB
'Copy the Range from dailyWB and Paste it into the MasterWB
.Worksheets("Summary1").Range(A1BJ200).Copy masterWB.Worksheets("Summary").Range("A1")
TrimRange masterWB.Worksheets("Summary").Range(A1BJ200)
'repeat for next Sheet
.Worksheets("risk1").Range(A1BJ200).Copy masterWB.Worksheets("risk").Range("A1")
TrimRange masterWB.Worksheets("risk").Range(A1BJ200)
'repeat for CS sheet
.Worksheets("CS today").Range(A1L3).Copy masterWB.Worksheets("CS").Range("A1").Rows("1:1")
TrimRange masterWB.Worksheets("CS").Range(A1L3)
.Close SaveChanges:=False
End With
End If
End Sub
Sub LoadLastWeeksWorkbook()
Const A1BJ200 As String = "A1:BJ200"
Dim masterWB As Workbook
Dim lastweekWB As Workbook
'Set Current Workbook as Master
Set masterWB = Application.ThisWorkbook
''''''''''''Get Last Week Data''''''''''''''''''''''
Set lastweekWB = getWorkbook(Workbooks.Open(Sheets("Control Manager").Range("O3")))
If Not lastweekWB Is Nothing Then
With lastweekWB
'repeat for next risk Sheet
.Worksheets("risk2").Range(A1BJ200).Copy masterWB.Worksheets("risk_lastweek").Range("A1")
TrimRange masterWB.Worksheets("risk_lastweek").Range(A1BJ200)
TrimRange masterWB.Columns("A:BB")
.Close SaveChanges:=False
End With
End If
End Sub
Function getWorkbook(FullName As String) As Workbook
If Len(Dir(FullName)) = 0 Then
MsgBox FullName & " not found found", vbCritical, "File Not Found"
Else
Set getWorkbook = Workbooks.Open(FullName)
End If
End Function
Sub TrimRange(Target As Range)
Dim results As Variant
Set Target = Intersect(Target.Parent.UsedRange, Target)
If Target Is Nothing Then
Exit Sub
ElseIf Target.Count = 1 Then
Target.Value = Trim(Target.Value)
Exit Sub
Else
Target = Target.Value
Dim r As Long, c As Long
For r = 1 To UBound(results)
For c = 1 To UBound(results, 2)
results(r, c) = Trim(results(r, c))
Next
Next
Target.Value = results
End If
Target.Columns.EntireColumn.AutoFit
End Sub
Sub TrimRange(Target As Range)
Dim results As Variant
And yet, you do not set results before you use it.
For r = 1 To UBound(results)
So you are calling UBound on some thing that does not exist.
In addition, when I have changed formulas to values, I have used Target.Value = Target.Value instead of Target = Target.Value. I know the .Value is usually the default value, but I never trust implicit stuff to work all the time.
I'm working with a sub which calls an input box to copy selected cells from a sheet and paste them into a multicolumn listbox. I've finally got everything working correctly, except the error 424 when the user cancels the inputbox. I've read through countless help threads regarding this error and have found nothing that seems to be able to handle the error for me. I'm hoping that someone out there can tell me if something is wrong with the code below (aside from 12 million exit sub attempts to stop the error), or possibly give me an idea of another area (Declarations, Initialization, Activate?) that I should be checking. Any ideas are appreciated, thanks.
Private Sub CopyItemsBtn_Click()
Dim x As Integer
Dim rSelected As Range, c As Range
Dim wb
Dim lrows As Long, lcols As Long
x = ProformaToolForm.ItemsLB.ListCount
'Prompt user to select cells for formula
On Error GoTo cleanup
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
If Err.Number = 424 Then
Debug.Print "Canceled"
Exit Sub
ElseIf Err.Number <> 0 Then
Debug.Print "unexpected error"
Exit Sub
End If
If rSelected.Rows.Count < 1 Or rSelected.Columns.Count < 1 Then
Exit Sub
End If
Err.Clear
On Error GoTo 0
'Only run if cells were selected and cancel button was not pressed
If Not rSelected Is Nothing Then
For Each c In rSelected
With ProformaToolForm.ItemsLB
.AddItem
.List = rSelected.Cells.Value
End With
Next
Else
Exit Sub
End If
cleanup: Exit Sub
End Sub
After some cleanup, here's my attempt with Tim's code:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range, c As Range
Dim wb
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
'Prompt user to select cells for formula
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
On Error GoTo 0
If rSelected Is Nothing Then
MsgBox "no range selected", vbCritical
Exit Sub
End If
For Each c In rSelected
With ProformaToolForm.ItemsLB
.AddItem
.List = rSelected.Cells.Value
End With
Next
End Sub
Here's how I'd tend to do this:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
On Error GoTo 0
If rSelected Is Nothing Then
MsgBox "no range selected!", vbCritical
Exit Sub
End If
'continue with rSelected
End Sub
Found a solution, from Dirk's final post here. For anyone interested, here is the working code:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range
Dim wb
Dim MyCol As New Collection
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
MyCol.Add Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
If TypeOf MyCol(1) Is Range Then Set MyRange = MyCol(1)
Set MyCol = New Collection
If rSelected Is Nothing Then
MsgBox "no range selected", vbCritical
Exit Sub
End If
ProformaToolForm.ItemsLB.List = rSelected.Value
End Sub
I am using this code to test whether worksheets are password protected in the specified workbook objXL.
Function IsProtected(objXL As Object) As Boolean
Dim wksht As Excel.Worksheet
Dim cell As Excel.Range
Select Case TypeName(objXL)
Case "Worksheet"
If objXL.ProtectContents Then
IsProtected = True
Exit Function
End If
Case "Workbook"
If objXL.ProtectStructure Then
IsProtected = True
Exit Function
End If
For Each wksht In objXL.Worksheets
If wksht.ProtectContents Then
IsProtected = True
Exit Function
End If
Next wksht
Case "Range"
If objXL.Cells.Count = 1 Then
If (objXL.Locked And objXL.Parent.ProtectContents) Or (IsProtected(objXL.Parent.Parent)) Then
IsProtected = True
Exit Function
End If
Else
For Each cell In objXL
If (cell.Locked And cell.Parent.ProtectContents) Or (IsProtected(cell.Parent.Parent)) Then
IsProtected = True
Exit Function
End If
Next cell
End If
End Select
End Function
The function fails to detect chart sheets that are password protected. Any ideas how I can modify this?
I believe it should work if you loop through all the sheets instead of all the worksheets (which don't include chart sheets). Try running the codes below in a workbook with chart sheets and see the difference.
Sub wkshts()
For Each ws In Worksheets
Name = Name & " " & ws.Name & vbNewLine
Next
MsgBox Name
End Sub
Sub shts()
For Each ws In sheets
Name = Name & " " & ws.Name & vbNewLine
Next
MsgBox Name
End Sub