The below code copy rows from sheet "Opened" (based on condition ) and paste on another sheet "Closed" in the same workbook and there is another event code on sheet "Closed" to prevent change name of that sheet.
Problems:(1) If I run copy code while sheet "Opened" is activated ,I got Run-time error 1004 That name is already taken. this error related to sheet "closed". no such error if I run code while sheet "closed is" activated.
Sub Copy_PasteSpecial()
Dim StatusColumn As Range
Dim DestRng As Range
Dim Cell As Object
Set StatusColumn = Sheets("Opened").Range("H3", Sheets("Opened").Cells(Rows.count, "H").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Set DestRng = Sheets("Closed").Range("A" & Rows.count).End(xlUp).Offset(1, 0)
Cell.EntireRow.Copy
DestRng.PasteSpecial xlPasteValuesAndNumberFormats
DestRng.PasteSpecial xlPasteFormats
End If
Next Cell
End Sub
And this code for Prevent Changing Sheet Name:
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If ActiveSheet.name <> "Closed" Then
ActiveSheet.name = "Closed"
End If
End Sub
This link for the real workbook: https://easyupload.io/7ftxik
The issue is that ActiveSheet in
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If ActiveSheet.name <> "Closed" Then
ActiveSheet.name = "Closed"
End If
End Sub
is not the sheet the SelectionChange event is in. That would be Target.Parent
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Parent.Name <> "Closed" Then
Target.Parent.Name = "Closed"
End If
End Sub
Related
I've been trying to write some macros to a cross-departmental spreadsheet, which when I press a command button will essentially "archive" a row of work. I also have one which is meant to auto-capitalise a column when people type in it. See below:
This is the Archive macro:
Sub Archive()
If MsgBox("Do you want to archive the selected row?" & vbNewLine & vbNewLine & "Row should only be archived after x has passed.", vbYesNo, "Archive") = vbNo Then Exit Sub
For Each WSheet In ActiveWorkbook.Worksheets
If WSheet.AutoFilterMode Then
If WSheet.FilterMode Then
WSheet.ShowAllData
End If
End If
For Each DTable In WSheet.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next WSheet
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim lastRow As Long
'Set variables
Set sht1 = Sheets("xDepartment")
Set sht2 = Sheets("Archive")
'Select Entire Row
Selection.EntireRow.Select
'Move row to destination sheet & Delete source row
lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
End Sub
The autocapitalisation macro is attached to the specific sheet? (i.e., it's attached when right-clicking on "xDepartment" and selecting "View code" - not sure if that has something to do with it?). There's also a macro on this sheet which calculates the date that data in a certain cell is changed:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("O:O,Q:Q,T:T,W:W")
If Not Intersect(Target, A1) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O, Q:Q"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
The error that comes up is "Run-time error '13': Type mismatch". Do you know why this might be happening?
Thanks in advance!
After your First line in the Archive macro put
Application.EnableEvents = False
On error goto Whoops
Then just above your End Sub for that macro put
Whoops:
Application.EnableEvents = True
This will turn off the other macro while your archive is running
Your code to move the row from xDepartment worksheet to Archive worksheet includes the line,
Selection.EntireRow.Select
This makes the xDepartment worksheet active. The code to actually move the row and remove the original does nothing to change the xDepartment as the ActiveSheet.
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
In your worksheet_change, you have,
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O, Q:Q"), Target)
So your Archive worksheet's Worksheet_Change is going to try to work on the xDepartment worksheet.
But you delete the row so it no longer exists; hen ce:
Run-time error '13': Type mismatch
Set your WorkRng with,
Set WorkRng = Intersect(Range("O:O, Q:Q"), Target)
It is in a private sub procedure on the Archive's private code sheet so there is no need to specify a parent worksheet unless you specifically want to work on another worksheet.
Avoid the use of ActiveSheet, Select, Selection and Activate whenever possible and never use them in a worksheet's private code sheet to refer to that worksheet.
Please can someone help me out, I seem to be going around in circles with my problem?
I have a workbook with 4 worksheets Comparison, Office1, Office2 and Office3. On the Comparison sheet the other sheet names are listed in column A. In column B on this sheet I have a button.
What I want to do is double click the button (I have sorted the code for this) and this will then take you to cell D5 on the corresponding sheet.
At the moment I have the following code but it doesn't seem to activate the Office sheet it uses the comparison sheet.
Could anyone please let me know what I am missing?
Thanks
Sub OfficeSht()
Dim rCrit3 As Range
Dim wb As Workbook
Dim ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rCrit3 = ActiveCell.Offset(RowOffset:=0, ColumnOffset:=-2)
Debug.Print rCrit3
Set ws = rCrit3.Worksheet
ws.Activate
ActiveSheet.Range("D5").Select
Application.EnableEvents = True
End Sub
Application.Goto seems appropriate and reduces the steps to achieve your goal.
Sub OfficeSht()
Dim ws As string
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
ws = ActiveCell.Offset(RowOffset:=0, ColumnOffset:=-2).value2
Debug.Print "'" & ws & "'!D5"
Application.Goto Reference:="'" & ws & "'!R5C4" '<~~ D5 in xlR1C1
With Application
.EnableEvents = true
.ScreenUpdating = true
End With
End Sub
You may want make this a Worksheet_BeforeDoubleClick event.
You don't say what kind of button you have so I've give a couple of examples.
One piece of code that is common in all examples is WorkSheetExists which checks if the sheet name corresponds to a worksheet.
Public Function WorkSheetExists(SheetName As String) As Boolean
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Next are three ways to call the OfficeSht procedure.
If your buttons are ActiveX button and are in column B you can use:
Private Sub CommandButton1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
OfficeSht Me.Shapes("CommandButton1").TopLeftCell
End Sub
This code returns a reference to Top Left Cell that your button sits in - assuming your sheet name is one cell to the left of this.
The second way is if you're using a Form button.
Public Sub Button_Click()
OfficeSht Me.Shapes(Application.Caller).TopLeftCell
End Sub
Again, it returns a reference to the Top Left Cell that the button is placed in. When you add the button just assign it to the Button_Click procedure.
The third way assumes your button is actually a cell formatted to look like a button, or if you just want to double-click the sheet name in column A and do away with having a button in column B:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
OfficeSht Target
End Sub
Finally, your code to select cell D5 (Row 5, Column 4 - R5C4).
If you're clicking, or referenced cell is in, column B:
Public Sub OfficeSht(ByVal Target As Range)
Dim rLastCell As Range
Dim rDataRange As Range
Set rLastCell = Cells(Rows.Count, 1).End(xlUp)
Set rDataRange = Range("A1", rLastCell)
If Not Intersect(Target, rDataRange.Offset(, 1)) Is Nothing Then
If WorkSheetExists(Target.Offset(, -1).Value) Then
Application.Goto "'" & Target.Offset(, -1).Value & "'!R5C4"
End If
End If
End Sub
If you're clicking, or referenced cell is in, column A:
Public Sub OfficeSht(ByVal Target As Range)
Dim rLastCell As Range
Dim rDataRange As Range
Set rLastCell = Cells(Rows.Count, 1).End(xlUp)
Set rDataRange = Range("A1", rLastCell)
If Not Intersect(Target, rDataRange) Is Nothing Then
If WorkSheetExists(Target.Value) Then
Application.Goto "'" & Target.Value & "'!R5C4"
End If
End If
End Sub
Might've waffled on a bit there.... :)
I am brand new to coding.
I am trying to use the code to move rows to different sheets and to move completed rows to a different work.
I am having trouble that the Sub Worksheet_Change is being seen as ambiguous name and doesn't work when I try to change the name to something like Worksheet_ChangeCOMPLETE or WorkSheet_Change3.
Below is the codes that I am trying to use.
What my plan is that I want completed orders (rows) to move to a new workbook in which I have named "COMPLETED" when a command button is pushed which triggers a Macro to insert the word "COMPLETE" in column 13 (M).
This new workbook was formerly my sheet 2 but I made it a new workbook following instruction from another forum. I also need rows to move to sheet 3 when "PARTIAL HOLD" inserted in column 13 via a different command button and then returned to sheet one when the command button on sheet 3 "RESUME" is clicked.
All workbooks and worksheets have all the same columns and spacing, I just can't get the codes to work when I rename them.
The first set of codes I am posting are for moving rows from sheet 1 to sheet 3 when the command button is pressed, followed by the code to move rows to the new workbook these codes are in Sheet 1 under VBA project, not a module.
The third is on sheet 3 to move rows back to sheet 1 once HOLD is complete.
Thank you in advance for your help.
SHEET 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range
Set rngDest = Sheet3.Range("A5:R5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
If UCase(Target) = "PARTIAL HOLD" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_ChangeCOMPLETE(ByVal Target As Range)
Dim destWbk As String
Dim wbk As Workbook
Dim rngDestCOMPLETE As Range
destWbk = ThisWorkbook.Names("Completed.xlsx").RefersTo
destWbk = Replace(destWbk, "=" & Chr(34), "")
destWbk = Replace(destWbk, Chr(34), "")
Set wbk = Application.Workbooks(destWbk)
Set rngDest = wbk.Names("A1:S1").RefersToRange
If Not Intersect(Target, Sheet1.Range("rngTrigger")) Is Nothing Then
If UCase(Target) = "COMPLETED" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
SHEET 3
Private Sub Worksheet_Change3(ByVal Target As Range)
Dim rngDest3 As Range
Set rngDest3 = Sheet1.Range("A5:S5")
If Not Intersect(Target, Sheet3.Range("M5:M290")) Is Nothing Then
If UCase(Target) = "IN PROGRESS" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
As I mentioned on the comment you cannot rename these Subs, but you can do something like below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range, rngDest2 As Range, rngDest3 As Range
Dim destWbk As String
Dim wbk As Workbook
If UCase(Target.Value) = "PARTIAL HOLD" Then
Set rngDest = Sheet3.Range("A5:R5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "IN PROGRESS" Then
Set rngDest3 = Sheet1.Range("A5:S5")
If Not Intersect(Target, Sheet3.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest3.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "COMPLETED" Then
destWbk = ThisWorkbook.Names("Completed.xlsx").RefersTo
destWbk = Replace(destWbk, "=" & Chr(34), "")
destWbk = Replace(destWbk, Chr(34), "")
Set wbk = Application.Workbooks(destWbk)
Set rngDest2 = wbk.Range("A1:S1")
If Not Intersect(Target, Sheet1.Range("rngTrigger")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest2.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
End If
End Sub
Apologies if this is simple, but I am new to VBA. I am attempting to set up the my Excel sheet so that when certain cells in the first sheet are changed (eg A1, A2, A3, A4) the names of four other sheets will change to match them. I have found the following formula which works if I change the specific cell on that sheet;
`
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Set Target = Range("A1")
If Target = "" Then Exit Sub
On Error GoTo Badname
ActiveSheet.Name = Left(Target, 31)
Exit Sub
Badname:
MsgBox "Please revise the entry in A1." & Chr(13) _
& "It appears to contain one or more " & Chr(13) _
& "illegal characters." & Chr(13)
Range("A1").Activate
End Sub
` Unfortunately it will not work if I change A1 to be dependent on one of the four cells on the main sheet specified previously, as it only looks for changes in the sheet it is saved in.
Is there a way to use VBA to look at a cell in one sheet and then change the sheet name of another sheet to match?
Thanks
Like I mentioned in the comments, it's not that simple to rename the sheet. You have to check for so many things.
My Assumptions
You have 5 Sheets in a workbook; Sheet1, Sheet2, Sheet3, Sheet4 and Sheet5
When you change cells in Sheet5, depending on the cell which changes, Sheets1-4's names are changed
I am assuming that when A1 changes, Sheet1 is renamed. When A2 changes, Sheet2 is renamed and so on...
Logic
Use Worksheet_Change event to trap changes to cell A1, A2, A3 or A4
Use Sheet CodeName to change the name
Check if the sheet name is valid. A sheet name cannot contain any of these Characters \ / * ? [ ]
Check if you already have a sheet with the name you want to use for renaming
If everything is hunky dory then go ahead and replace
Code
See this example. This code goes in the Sheet5 code area.
Dim sMsg As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsName As String
On Error GoTo Whoa
sMsg = "Success"
Application.EnableEvents = False
If Not Target.Cells.CountLarge > 1 Then
If Not Intersect(Target, Range("A1")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet1], wsName
ElseIf Not Intersect(Target, Range("A2")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet2], wsName
ElseIf Not Intersect(Target, Range("A3")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet3], wsName
ElseIf Not Intersect(Target, Range("A4")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet4], wsName
End If
End If
MsgBox sMsg
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
'~~> Procedure actually renames the sheet
Sub RenameSheet(ws As Worksheet, sName As String)
If IsNameValid(sName) Then
If sheetExists(sName) = False Then
ws.Name = sName
Else
sMsg = "Sheet Name already exists. Please check the data"
End If
Else
sMsg = "Invalid sheet name"
End If
End Sub
'~~> Check if sheet name is valid
Function IsNameValid(sWsn As String) As Boolean
IsNameValid = True
'~~> A sheet name cannot contain any of these Characters \ / * ? [ ]
For i = 1 To Len(sWsn)
Select Case Mid(sWsn, i, 1)
Case "\", "/", "*", "?", "[", "]"
IsNameValid = False
Exit For
End Select
Next
End Function
'~~> Check if the sheet exists
Function sheetExists(sWsn As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sWsn)
On Error GoTo 0
If Not ws Is Nothing Then sheetExists = True
End Function
Screenshot
The situation is simple, if I name cell A1 to be MY_CELL and then CUT AND PASTE from cell A2 to cell MY_CELL, then MY_CELL will lose that name and be named A1 again.
However, this does not happen when I COPY AND PASTE from A2 to MY_CELL.
How can I prevent Excel from resetting cell names on CUT AND PASTE?
Logic: Trap the changes to Cell A1 using the Worksheet_Change event and recreate the name if it is lost.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DoesRngNameExists As Boolean
Dim sName As String
On Error GoTo Whoa
Application.EnableEvents = False
'~~> You named range
sName = "MY_CELL"
If Not Intersect(Target, Range("A1")) Is Nothing Then
'~~> Check if the Range exists
On Error Resume Next
DoesRngNameExists = Len(Names(sName).Name) <> 0
On Error GoTo 0
'~~> If not then recreate it
If DoesRngNameExists = False Then _
ThisWorkbook.Names.Add Name:=sName, RefersToR1C1:="=Sheet1!R1C1"
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Note: The codes in the Sheet code area of the relevant sheet. See screenshot below.