I was trying to find a VBA code that would move rows from one sheet to another and found this block of code. It works perfectly, except for when I delete an entire row. When I delete an entire row it gives me this error.
Here's the VBA code i'm using. How can I change it so it doesn't give me this error?
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("A:A,Y:Y")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Dim bottomB As Long
Select Case Target.Column
Case Is = 1
bottomB = Sheets(Target.Value).Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Range("A" & Target.Row).Resize(, 25).Copy Sheets(Target.Value).Cells(bottomB, 1)
Target.EntireRow.Delete
End Select
Application.EnableEvents = True
End Sub
It will throw this error if multiple cells get changed at the same time so when the change event code triggers you may check to see if multiple cells are changed and then exit the code.
Try this code to see if this resolves the issue you are having.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Intersect(Target, Range("A:A,Y:Y")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Dim bottomB As Long
Select Case Target.Column
Case Is = 1
bottomB = Sheets(Target.Value).Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Range("A" & Target.Row).Resize(, 25).Copy Sheets(Target.Value).Cells(bottomB, 1)
Target.EntireRow.Delete
End Select
Application.EnableEvents = True
End Sub
Related
First let me say that I am freshly new to VBA coding. My spreadsheet has 8 tabs(1 hidden and 1's a chart). Of the other 6 tabs, I would like the code to be able to run on them as well, I just don't know how. I have two sets of code and I am trying to combine them. They are event related codes. I can get them both to run separately but only on a specified sheet. I'm testing them on the "New" tab. The first code sorts the rows after the date is entered into column "H". The other code will cut and paste the entire row into the corresponding tab based on a selection from the drop down list in column "O". I created a call function for both however, only the first code will do anything. Here is what I have so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChng As Range
Set rngChng = Intersect(Target, Range("H:H"))
If rngChng Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
Call AutoSort(rngChng)
Set rngChng = Intersect(Target, Range("O:O"))
If rngChng Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Call CopyNPaste(rngChng)
Application.ScreenUpdating = True
End Sub
Sub AutoSort(rngChng As Range)
Range("A2:O1000").Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlNo
End Sub
Sub CopyNPaste(rngChng As Range)
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name <> "New" Then
If ws.Name = Target Then
Target.EntireRow.Copy Sheets(ws.Name).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete Shift:=x1Up
End If
End If
Next ws
End Sub
To run the same code from many sheets move the code to a module. Use insert->module on the menu bar, if there are no others it will be named Module1.
In each relevant sheet add the code
Private Sub Worksheet_Change(ByVal Target As Range)
Call Module1.sortOrCopy(Target)
End Sub
Put the sortOrCopy sub in the module. I would suggest using the Target.column
value rather than Intersections to control the program flow.
Put the target.cells.count check once at the start. Pass parameters to your 2 subs.
Sub sortOrCopy(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Dim ws As Worksheet
Set ws = Target.Parent
If Target.Column = 8 Then ' col H
Call AutoSort(ws)
ElseIf Target.Column = 15 Then ' col O
Call CopyNPaste(Target)
End If
End Sub
For the AutoSort sub the only parameter required is the sheet which will be Target.parent.
You can set the sort range rather than hard coding it using .end(xlUp.row as you have in the other sub.
Sub AutoSort(ws As Worksheet)
Dim iLastRow As Long
' last row of sort range
iLastRow = ws.Range("H" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:O" & iLastRow).Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlNo
Application.ScreenUpdating = True
End Sub
For the sub CopyNPaste, pass the Target so that the source,row and destination can be determined.
Try to structure the code in simple steps by not doing too much in one line. If the code doesn't work as expected it is easier then to add debug.print or msgBox statements at the various steps. Comment out the If .. End if you don't want user confirmation of the change.
Sub CopyNPaste(Target)
Dim wsCopyTo As Worksheet, iInsertRow As Long, text As String
Set wsCopyTo = Sheets(Target.Value)
' find last row on CopyTo sheet, insert below
iInsertRow = 1 + wsCopyTo.Range("A" & Rows.Count).End(xlUp).Row
text = "Copy line to sheet " & wsCopyTo.Name & " row " & iInsertRow
If MsgBox(text, vbYesNo) = vbYes Then
With Target.EntireRow
.Copy wsCopyTo.Range("A" & iInsertRow)
.Delete Shift:=xlShiftUp
End With
End If
End Sub
i have trouble getting this code to work on the last to columns (T and U)
what can i do to change tis?
code:
Private Sub Worksheet_ChangeS(ByVal Target As Range) 'column s, structure
If Intersect(Target, Range("S:S")) Is Nothing Then Exit Sub
Dim foundVal As Range
Set foundVal = Sheets("Dropdown").Range("A:A").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(0, 1)
End If
End Sub
Private Sub Worksheet_ChangeT(ByVal Target As Range) 'column t, component
If Intersect(Target, Range("T:T")) Is Nothing Then Exit Sub
Dim foundVal As Range
Set foundVal = Sheets("Dropdown").Range("D:D").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(0, 1)
End If
End Sub
Private Sub Worksheet_ChangeU(ByVal Target As Range) 'column U, parameter
If Intersect(Target, Range("U:U")) Is Nothing Then Exit Sub
Dim foundVal As Range
Set foundVal = Sheets("Dropdown").Range("I:I").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(0, 1)
End If
End Sub
Thanks in advance
There's only one Worksheet_Change event that fires whenever a cell is changed.
Private Sub Worksheet_ChangeS(ByVal Target As Range) would have to be "manually" called from the Worksheet_Change event to work as it's a user defined procedure.
You should delete those three procedures and using something along the lines of:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lCol As Long
Dim foundVal As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("S:U")) Is Nothing Then
If Target.Cells.Count = 1 Then 'Check a single cell is changing.
Select Case Target.Column
Case 19 'col S
lCol = 1
Case 20 'col T
lCol = 4
Case 21 'col U
lCol = 9
End Select
Set foundVal = Worksheets("DropDown").Columns(lCol).Find( _
Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(, 1)
End If
End If
End If
Application.EnableEvents = True
End Sub
Although looking at the range you then try and use FIND on you should be able to offset from the Target column and do the find in a single statement rather than three.
Edit:
I've updated the code to include EnableEvents. At the end of your code you change the value of Target which would cause the Worksheet_Change event to fire again. EnableEvents stops that from happening.
Edit 2:
I've updated the code to use a single FIND. The Select Case gives the column to search in the FIND command.
Note:
If your code crashes for any reason you may need to open the immediate window (Ctrl+G) and type in Application.EnableEvents = True as this does not reset when the code stops - you'll just notice that all your event code stops firing.
I want to insert or remove a "X" inside cells inside a certain range ("A1:A19"), by double clicking. The code below is placed on the "Microsoft Excel Objects\ThisWorkbook" in the project macro.
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A19")) Is Nothing Then
If Len(Trim(Target)) = 0 Then
Target.Value = "X"
Cancel = True
ElseIf UCase(Trim(Target)) = "X" Then
Target.ClearContents
Cancel = True
End If
End If
End Sub
This code works for non merged cells. However, I have a situation where the cells must be merged ( 2 by 2, in the column), and in this situation I get the following error:
"Run-time error '13'"
Type mismatch
How must be the code modified to prevent this?
try
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A19")) Is Nothing Then
If Target.Cells.Count = 1 Then ' handle single cell
If Len(Trim(Target)) = 0 Then
Target.Value = "X"
Cancel = True
ElseIf UCase(Trim(Target)) = "X" Then
Target.ClearContents
Cancel = True
End If
Else ' handle merged
Dim theAddress As String
theAddress = Split(Target.Address, ":")(0) & ":" & Split(Target.Address, ":")(0)
If Len(Trim(Range(theAddress))) = 0 Then
Target.Value = "X"
Cancel = True
ElseIf UCase(Trim(Range(theAddress))) = "X" Then
Target.ClearContents
Cancel = True
End If
End If
End If
End Sub
When your cells are merged, target is returning a range of multiple cells and it is trying to put a value into cells it can't put values into. Try this:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim myRange As Range
Set myRange = Target.Cells(1, 1)
If Not Intersect(myRange, Range("A1:A19")) Is Nothing Then
If Len(Trim(myRange)) = 0 Then
myRange.Value = "X"
Cancel = True
ElseIf UCase(Trim(myRange)) = "X" Then
Target.ClearContents
Cancel = True
End If
End If
End Sub
It returns a range reference as being the top left cell in your merged range and allows you to enter values based on that.
I have Worksheet 1, with columns A to D.
I would like to create a button executing row to be copied to Worksheet 2, as soon as cell C in Worksheet 1 is populated.
I have no experience in Excel at all, so far I found and altered this macro code for my needs:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Target.EntireRow.Copy _
Destination:=Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
End Sub
But when I try to create a button to execute this macro, it would never work. Could anyone help me solve this, please.
Is this what you are trying? Read more about Worksheet_Change HERE
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim lRow As Long
On Error GoTo Whoa
Application.EnableEvents = False
If Target.Cells.CountLarge > 1 Then Exit Sub
Set ws = ThisWorkbook.Sheets("Sheet2")
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
If Not Intersect(Target, Columns(3)) Is Nothing Then _
Target.EntireRow.Copy Destination:=ws.Rows(lRow)
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
EDIT:
If the code still doesn't work then from the VBA Editor, press CTRL + G to bring up the immediate window and type this
Application.EnableEvents = True
and press ENTER key and now the code should work.
people, my doubts is simple .. I created a spreadsheet in excel with several fields, eg:
NAME ADDRESS PHONE
carlos ave. 1 12345678
Argeu av .2 87654321
After this, I used the following code in the module:
Private Sub Worksheet_Activate()
ActiveSheet.ScrollArea = "$A$2:$A$300"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
Dim LR As Long
LR = Cells(Rows.Count, "A").End(xlUp).Row
Range("$A$2:$A" & LR).Sort Key1:=Range("$A$2")
End Sub
This code will make in the example table, the Argeu stand on the carlos, so far so good, but I want when the Argeu is up from carlos the phone and address data also rise ..
If anyone can help, thank you
IF you want Col C to be also sorted then include that in the sort range as well. See this.
Change
Range("$A$2:$A" & LR).Sort Key1:=Range("$A$2")
to
Range("$A$2:$C" & LR).Sort Key1:=Range("$A$2")
EDIT
Your code can be properly re-written as
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
'~~> For xl2007+ use .CountLarge
If Target.Cells.CountLarge > 1 Then Exit Sub
'~~> For xl2003 use .Count
'If Target.Cells.Count > 1 Then Exit Sub
Dim LR As Long
If Application.WorksheetFunction.CountA(Cells) <> 0 Then
LR = Cells.Find(What:="*", _
After:=Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LR = 1
End If
Range("$A$2:$C" & LR).Sort Key1:=Range("$A$2")
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
ScreenShot