I am running a VBA script to auto-capitalize and remove hyphens from pasted data into Excel. This script works great on single-line pastes (single-cell), but will not run (does nothing to change the data) if multiple lines of data are pasted in. The following is my code:
Private Sub worksheet_change(ByVal target As Range)
Application.EnableEvents = False
With target
On Error Resume Next
Dim rng As Range
Set rng = Range("A:U")
If Not Intersect(target, rng) Is Nothing Then
If Not .HasFormula Then
.Value = UCase(.Value)
.Value = Replace(.Value, "-", "")
End If
End If
End With
Application.EnableEvents = True
End Sub
Try this
Private Sub worksheet_change(ByVal target As Range)
Application.EnableEvents = False
With target
On Error Resume Next
Dim rng As Range
Dim cell As Range
Set rng = Range("A:U")
If Not Intersect(target, rng) Is Nothing Then
For Each cell in target
If Not cell.HasFormula Then
cell.Value = UCase(cell.Value)
cell.Value = Replace(cell.Value, "-", "")
End If
next cell
End If
End With
Application.EnableEvents = True
End Sub
Related
I have a macro that detects when a cell is changed, and adds this number to cell above it.
However I then need to clear the original cell, which always triggers the macro again as that cell is being changed again, and I end up an endless loop. Is there a way to "ignore" any other cell changes whilst the macro runs?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B3:O3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Range(Target.Address).Cells.Count = 1 Then
Range(Target.Address).Offset(-1).Value = Range(Target.Address).Offset(-1).Value + Range(Target.Address).Value
Range(Target.Address).Clear
End If
End If
End Sub
Or simply add Application.EnableEvents as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B3:O3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Range(Target.Address).Cells.Count = 1 Then
Application.EnableEvents = False
Range(Target.Address).Offset(-1).Value = Range(Target.Address).Offset(-1).Value + Range(Target.Address).Value
Range(Target.Address).Clear
Application.EnableEvents = True
End If
End If
End Sub
You can add additional condition:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A3:O3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing And Range(Target.Address).Value <> "" Then
If Range(Target.Address).Cells.Count = 1 Then
Range(Target.Address).Offset(-1).Value = Range(Target.Address).Offset(-1).Value + Range(Target.Address).Value
Range(Target.Address).Clear
End If
End If
End Sub
I have the following sub in a worksheet, but I need another 3 of the same in the same worksheet for different cells/pivots. How can I do that?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell
'B1 or B2 is touched
If Intersect(Target, Range("B1:B2")) Is Nothing Then Exit Sub
'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewCat As String
'Here you amend to suit your data
Set pt = Worksheets("Daily Overall").PivotTables("DailyOverallSignups")
Set Field = pt.PivotFields("Reg Year")
NewCat = Worksheets("Daily Overall").Range("B1").Value
'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewCat
pt.RefreshTable
End With
End Sub
I assume that by "the same" you mean that they all need to be in worksheet_selectionchange? Since your code currently exits if it isn't b1:b2, change your code to not exit at that point by adding other ranges. You should also have error handling and enableevents in there.
Private Sub Worksheet_SelectionChange(ByVal target As Range)
On Error GoTo Bummer
'This line stops the worksheet updating on every change, it only updates when cell
'B1 or B2 is touched
If Not Intersect(target, Range("B1:B2")) Is Nothing Then 'if not nothing
Application.EnableEvents = False
'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewCat As String
'Here you amend to suit your data
Set pt = Worksheets("Daily Overall").PivotTables("DailyOverallSignups")
Set Field = pt.PivotFields("Reg Year")
NewCat = Worksheets("Daily Overall").Range("B1").Value
'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewCat
pt.RefreshTable
End With
ElseIf Not Intersect(target, Range("c1:c2")) Is Nothing Then
Application.EnableEvents = False
MsgBox ("Foo")
ElseIf Not Intersect(target, Range("d1:d2")) Is Nothing Then
Application.EnableEvents = False
MsgBox ("Bar")
ElseIf Not Intersect(target, Range("e1:e2")) Is Nothing Then
Application.EnableEvents = False
MsgBox ("Hello World")
Else
Exit Sub
End If
MovingOn:
Application.EnableEvents = True
Exit Sub
Bummer:
MsgBox Err.Description
Resume MovingOn
End Sub
Currently I managed to do for a single cell when the specified cell is empty then message / statement display on the cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("AA17").Value = ISBLANK Then
Range("AA17").Value = "Please Specify"
End If
End Sub
What I would like to do is, for a several cell it will display the same thing. I can go ahead and do the same as above for all celsl but I have a few hundred cell to format it that way.
Is there a way to do so?
If the cells are contiguous, you could loop through them.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim checkRng As Range
Dim cel As Range
Set checkRng = Range("A7:A70")
For Each cel In checkRng
If cel.Value = ISBLANK Then
cel.Value = "Please Specify"
End If
Next cel
End Sub
if there is any changes within the specified Range, the below code will run
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set Rng = ws.Range("A1:A100")
If Not Intersect(Target, Rng) Is Nothing Then
For Each Cell In Rng
If IsEmpty(Cell.Value) = True Then
Cell.Value = "Please Specify"
End If
Next
End If
Set Rng = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
I have a UserForm which should be able to copy paste cells ideally. So firstly I would click the range I would want to copy, then activate the UserForm. The UserForm would have a combo box to choose which sheet I want to paste the data in, thereafter it would go to that sheet and user will click on the range or cell where he wants the data to be pasted.
I originally did an input box code to do this and it works perfectly, however when I do it in the UserForm it does not work as I am not able to incorporate the Type:=8 code in the textbox. Hence I would need some help on how can I enable my UserForm to paste cell data on the sheet, similarly to what I have done in application.inputbox.
This is the perfectly working code in the form of an input box:
Sub CopyPasteCumUpdateWithinSameSheet()
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
Exit Sub
Else
inp.Copy
rng.Select
ActiveSheet.Paste Link:=True
'Cells(1,2).Font.ThemeColor =
End If
End Sub
This is the UserForm I have tried:
Dim Sh As Worksheet
Private Sub CommandButton1_Click()
On Error GoTo 0
If TypeName(rng) <> "Range" Then
Exit Sub
Else
inp.Copy
rng.Select
ActiveSheet.Paste Link:=True
End If
End Sub
Private Sub UserForm_Initialize()
CopyPasteUserform.Show vbModeless
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Inputs" Then
ComboBox1.AddItem Sh.Name
End If
Next
ComboBox1.Style = fmStyleDropDownList
End Sub
Private Sub ComboBox1_Change()
With ThisWorkbook.Sheets(ComboBox1.Text)
.Visible = xlSheetVisible
.Activate
End With
End Sub
Private Sub TextBox1_Change()
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
On Error Resume Next
Set rng = TextBox.Value
End Sub
I tried incorporating the UserForm but all other functions stop responding apart from the RefEdit.
Dim Sh As Worksheet
Private Sub UserForm_Initialize()
CopyPasteUserform.Show vbModeless
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Inputs" Then
ComboBox1.AddItem Sh.Name
End If
Next
ComboBox1.Style = fmStyleDropDownList
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
End Sub
Private Sub Combobox1_Change()
With ThisWorkbook.Sheets(ComboBox1.Text)
.Visible = xlSheetVisible
.Activate
End With
End Sub
Private Sub RefEdit1_Change()
Label1.Caption = ""
If RefEdit1.Value <> "" Then _
Label1.Caption = "[" & ComboBox1 & "]" & RefEdit1
Dim rng As Range
Dim inp As Range
On Error Resume Next
Set rng = RefEdit1.Value
On Error GoTo 0
If TypeName(rng) <> "Range" Then
Exit Sub
Else
inp.Copy
rng.Select
ActiveSheet.Paste Link:=True
End If
End Sub
You do not need the combobox to navigate to the sheets. That is the beauty of the Refedit
Is this what you are trying? I have not done any error handling. I am sure you can take care of that.
Create a userform and place 2 labels, 2 refedits and 1 commandbutton as shown below
Next paste this code in the userform code area
Code
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
If RefEdit1.Value <> "" And RefEdit2.Value <> "" Then
Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", ""))
Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1))
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(RefEdit2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(RefEdit2.Value, "!")(1))
rngCopy.Copy rngPaste
Else
MsgBox "Please select Input and Output range"
End If
End Sub
In Action
The data will be copied from Sheet1!$A$1:$A$3 to Sheet2!$A$1:$A$3
Followup From Comments
However the pastelink feature has been missed out in the userform. Is it possible to incorporate it?:) – Niva 7 mins ago
Add a checkbox to the form as shown below
Use this code
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
If RefEdit1.Value <> "" And RefEdit2.Value <> "" Then
Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", ""))
Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1))
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(RefEdit2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(RefEdit2.Value, "!")(1))
If CheckBox1.Value = True Then
wsPaste.Activate
rngPaste.Select
rngCopy.Copy
ActiveSheet.Paste Link:=True
Else
rngCopy.Copy rngPaste
End If
Else
MsgBox "Please select Input and Output range"
End If
End Sub
Description: Type:=8 will check that user input correct range name or not? In UserForm the TextBox not have this function. But we can detect this error when user click button. see my code.
No need to check when textbox is change, I delete code of textbox_change.
Replace below in your user form code area.
Option Explicit
Dim Sh As Worksheet
Dim inp As Range
Dim rng As Range
Private Sub CommandButton1_Click()
ActiveCell.Value = Me.TextBox1.Text
'On Error Resume Next
'If TypeName(Range(Me.TextBox1.Text)) <> "Range" Then
' MsgBox "Invalid range name!", vbCritical
' Exit Sub
'Else
' inp.Copy
' rng.Select
'
' ActiveSheet.Paste Link:=True
' MsgBox "Copy and paste finish.", vbInformation
'End If
'On Error GoTo 0
End Sub
Private Sub UserForm_Initialize()
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Inputs" Then
ComboBox1.AddItem Sh.Name
End If
Next
ComboBox1.Style = fmStyleDropDownList
End Sub
Private Sub ComboBox1_Change()
With ThisWorkbook.Sheets(ComboBox1.Text)
.Visible = xlSheetVisible
.Activate
End With
End Sub
I want to combine these two lines of code but cannot figure out how to get it to work. They both work separately, but I want the first line of code to be the first operation and then the second sub to be the second operation. These should execute whenever there is a change to the worksheet. The first routine should only cause a msg box when the corresponding cell in the "S" range updates in the same row as the cell that was updated in column A or B.
The second operation should look for any change in range "T7:T26" and prompt a msg box.
Code is below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Dim lRow As Long
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Set myRng = Range("A7:B26")
Application.EnableEvents = False
If Not Intersect(Target, myRng) Is Nothing Then
lRow = Target.Row
If Range("S" & lRow).Value >= 16 Then sVar = _
MsgBox("Will Enough Pre-Wave Resources be Available?", 4, "Attention!")
If sVar = 7 Then Application.Undo
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
and
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Set myRng = ThisWorkbook.Sheets("SMT 5").Range("T7:T26")
For Each mycell In myRng
If mycell.Value = "ISSUE" Then sVar = MsgBox("Possible Pre-Wave Manpower Issue on 2nd or 3rd Shift. Will Enough Resources be Available?", 4, "Attention!")
If sVar = 7 Then
Application.Undo
End If
Exit For
Next
End Sub
If both of them work on their own, you can copy the code into a module and give them two distinct names.
Then, in the Worksheet_Change sub you just use Call to run both subs.
Is this what you are trying?
Const sMsg1 As String = "Will Enough Pre-Wave Resources be Available?"
Const sMsg2 As String = "Possible Pre-Wave Manpower Issue on " & _
"2nd or 3rd Shift. Will Enough Resources be Available?"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range, othrRng As Range, aCell As Range
Dim lRow As Long
Dim sVar
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Set myRng = Range("A7:A26")
Set othrRng = Range("T7:T26")
Application.EnableEvents = False
If Not Intersect(Target, myRng) Is Nothing Then
lRow = Target.Row
If Range("S" & lRow).Value >= 16 Then sVar = _
MsgBox(sMsg1, 4, "Attention!")
If sVar = 7 Then Application.Undo
End If
For Each aCell In othrRng
If aCell.Value = "ISSUE" Then _
sVar = MsgBox(sMsg2, 4, "Attention!")
If sVar = 7 Then
Application.Undo
Exit For
End If
Next
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Dim lRow As Long
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Set myRng = Range("A7:B26")
Application.EnableEvents = False
If Not Intersect(Target, myRng) Is Nothing Then
lRow = Target.Row
If Range("S" & lRow).Value >= 16 Then sVar = _
MsgBox("Will Enough Pre-Wave Resources be Available?", 4, "Attention!")
If sVar = 7 Then Application.Undo
End If
Set othrRng = Range("T7:T26")
For Each aCell In othrRng
If aCell.Value = "ISSUE" Then sVar = MsgBox("Possible Pre-Wave Manpower Issue on 2nd or 3rd Shift. Will Enough Resources be Available?", 4, "Attention!")
If sVar = 7 Then
Application.Undo
Exit For
End If
Next
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub