Want sequence to start on Cell A4. so that A4 is 1, A5 is 2 et al to A1004 = 1004
Tried changing [Range("A" & I)..] to [Range("A4" & I)..]
Tried changing I=4
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
I = 1
Application.EnableEvents = False
For I = 1 To 1000
Range("A" & I).Value = I
Next
Range("A1010").Value = ""
Application.EnableEvents = True
End Sub
Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
Set startRng = Cells(4, 1)
Application.EnableEvents = False
For I = 0 To 999
startRng.Offset(I, 0) = I
Next
Range("A1010").Value = ""
Application.EnableEvents = True
End Sub
Related
I have 2 sheets in same workbook, one is data sheet and 2nd sheet contains the data validation values. I am facing problem while removing value from a cell (in data sheet) (which contains data validation). The issue is when I try to remove the value from validation list, the same value didn't remove from the cell. (see screen shot)
"e.g. if I want to remove volunteer name from the validation list, the value didn't delete from cell in data sheet (cell highlighted in screenshot)."
I have written a vba code to add multiple values in same cell separated by commas. I would appreciate if someone help me to solve this issue.
My VBA code is below:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 3 Or Target.Column = 4 Or Target.Column = 5 Or Target.Column = 6 Or
Target.Column = 7 Or Target.Column = 8 _
Or Target.Column = 9 Or Target.Column = 11 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal & ", ", "")
End If
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
You can find the worksheet from the link below: (show1 Sheet is data sheet and Validation Fields contains the drop-down values)
Excel Sheet
Thanks
This code works for me:
Private Sub Worksheet_Change(ByVal Target As Range)
Const SEP As String = ","
Dim c As Range, NewValue As String, OldValue As String, arr, v, lst, removed As Boolean
On Error GoTo Exitsub
If Target.CountLarge > 1 Then Exit Sub '<< only handling single-cell changes
Select Case Target.Column
Case 3, 4, 5, 6, 7, 8, 9, 11
Set c = Target
Case Else: Exit Sub
End Select
If Len(c.Value) > 0 And Not c.Validation Is Nothing Then
Application.EnableEvents = False
NewValue = c.Value
Application.Undo
OldValue = c.Value
If OldValue = "" Then
c.Value = NewValue
Else
arr = Split(OldValue, SEP)
'loop over previous list, removing newvalue if found
For Each v In arr
If Trim(CStr(v)) = NewValue Then
removed = True
Else
lst = lst & IIf(lst = "", "", SEP) & v
End If
Next v
'add the new value if we didn't just remove it
If Not removed Then lst = lst & IIf(lst = "", "", SEP) & NewValue
c.Value = lst
End If
End If 'has validation and non-empty
Exitsub:
If Err.Number <> 0 Then MsgBox Err.Description
Application.EnableEvents = True
End Sub
I am getting an error when I am trying to capture an old value from a cell:
run-time error '13' Type mismatch.
This is the code I am using:
Dim oldValue As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target(1, 1).Value
MsgBox oldValue
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'check if one of the target columns is changed
If Target.Cells.Column = 6 Or Target.Cells.Column = 9 Or Target.Cells.Column = 10 Or Target.Cells.Column = 11 Then
'Set variables
Dim LogActivity As String
Dim cRow As Integer
Dim pRowCount As Integer
Dim wsPBS As Worksheet
Dim wsHistoric As Worksheet
Set wsPBS = Sheets("PBS")
Set wsHistoric = Sheets("Historic")
cRow = Target.Cells.Row
pRowCount = wsHistoric.Range("A" & Rows.Count).End(xlUp).Row + 1
'Check for blanks on PBS sheet and exit if entry is not complete
Dim BlankCount As Integer
BlankCount = 0
If wsPBS.Range("D" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("E" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("F" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("H" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("I" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("J" & cRow).Value = "" Then BlankCount = BlankCount + 1
If BlankCount >= 1 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Target.Cells.Column = 6 Then LogActivity = "Owner change"
If Target.Cells.Column = 9 Then LogActivity = "Status change"
If Target.Cells.Column = 10 Then LogActivity = "Priority change"
If Target.Cells.Column = 11 Then LogActivity = "Completion rate"
Range("C" & cRow & ":O" & cRow).Select
Selection.Copy
wsHistoric.Select
wsHistoric.Range("F" & pRowCount).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wsHistoric.Range("A" & pRowCount).Value = Date
wsHistoric.Range("B" & pRowCount).Value = Time
wsHistoric.Range("C" & pRowCount).Value = Application.UserName
wsHistoric.Range("D" & pRowCount).Value = LogActivity
wsHistoric.Range("E" & pRowCount).Value = oldValue
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub
The value is supposed to be stored in a global dim called 'oldValue' so I can use it later on in my code.
The cell I am clicking does contain a string.
Any suggestions?
The main issue:
You're Selecting within the Worksheet_Change event.
Range("C" & cRow & ":O" & cRow).Select
Selection.Copy
That fires the Selection_Change event again, overwriting oldValue.
No need to Select here. See How to avoid using Select in Excel VBA.
Range("C" & cRow & ":O" & cRow).Copy
The secondary (yet still very important issue):
In your original version of the selection change:
Dim oldValue As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Value
End Sub
This will throw a type mismatch error if Target doesn't contain a String or something that can be coerced to a String.
In your instance, that was because Target actually was multiple cells: Range("C" & cRow & ":O" & cRow).
But your code would also throw an error if you selected a cell with an error value (#N/A, #DIV/0, etc.).
The fix:
First of all, avoid using Select, as already noted.
If for some (rare) reason you absolutely need to Select, then toggle events off and on:
Private Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
... do your stuff
Application.EnableEvents = True
End Sub
Lastly, within the selection change, instead of assuming that you'll only select a string, or only select one cell, add some validation.
Dim oldValue As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge <> 1 Then Exit Sub ' ignore a multi-cell selection
If IsError(Target.Value) Then Exit Sub ' ignore selection of errors
oldValue = Target.Value
End Sub
Try identifying a single cell withing Target:
oldValue = Target(1,1).Value
I have a strange problem. That code works as long as I don't assign addresses of cells to the variables komorka_k and komorka_y. Since 2 lines of the code marked with "LINE 1" and "LINE 2" are disabled, VBA macro works properly. What is the reason for such an activity? How is it possible that assigning a value not connected with any other part of a submodule makes it acting differently?
Public stara_wartosc As Variant
Public czy_wiekszy_zakres As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x, y As Integer
Dim x_err As Integer
Const y_err = 4
Dim nowa_wartosc As Variant
Dim komorka_x As String
Dim komorka_y As String
Const kon_col = 72
komorka_x = ""
komorka_y = ""
x = Target.row
y = Target.Column
nowa_wartosc = Target.Value
If czy_wiekszy_zakres = True Then
stara_wartosc = nowa_wartosc
End If
On Error GoTo TypeMismatch
If stara_wartosc <> nowa_wartosc And czy_wiekszy_zakres = False Then
If Target.Worksheet.Cells(x, 2).Value = "" Or Target.Worksheet.Cells(x, 2).Value = 0 Then
Application.EnableEvents = False
Target.ClearContents
MsgBox Prompt:="Zmieniłeś wartość komórki bez wpisania numeru zlecenia." & vbCrLf & "Wpisz nr zlecenia!", Title:="ZACHOWUJESZ SIĘ NIEWŁAŚCIWIE, MÓJ DROGI!"
Target.Worksheet.Cells(x, 2).Activate
Application.EnableEvents = True
Exit Sub
End If
With ActiveWorkbook.Worksheets("Errata")
komorka_x = .Range("A:A").Find(x, LookIn:=xlValues).Address 'LINE 1
komorka_y = .Range("B:B").Find(y, LookIn:=xlValues).Address 'LINE 2
x_err = .Cells(Rows.Count, 1).End(xlUp).row + 1
If .Cells(x_err, 1).Value = 0 Or .Cells(x_err, 1).Value = "" Then
.Cells(x_err, 1).Value = x
End If
If .Cells(x_err, 2).Value = 0 Or .Cells(x_err, 2).Value = "" Then
.Cells(x_err, 2).Value = y
End If
Set_values:
.Cells(x_err, y_err - 1).Value = stara_wartosc
.Cells(x_err, y_err).Value = Target.Value
.Cells(x_err, y_err + 1).Value = Target.Worksheet.Cells(x, 2).Value
End With
End If
TypeMismatch:
If Err = 13 Then
Exit Sub
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count = 1 Then
stara_wartosc = Target.Value
czy_wiekszy_zakres = False
Else
czy_wiekszy_zakres = True
End If
End Sub
Probably
komorka_x = .Range("A:A").Find(x, LookIn:=xlValues).Address
komorka_y = .Range("B:B").Find(y, LookIn:=xlValues).Address
doesn't find anything. Therefore .Address fails because no find result no address.
Then because of On Error GoTo TypeMismatch it jumps to the error handling here.
So make sure .Find is not nothing:
Dim FoundX As Range
Set FoundX = .Range("A:A").Find(x, LookIn:=xlValues)
If Not FoundX Is Nothing Then
komorka_x = FoundX.Address
Else
MsgBox "Nothing found for x=" & x
End If
Having trouble with time formatting.
I have set the cell to custom format 00:00.
Currently in column A a date is inputted, this can be as 0300 which converts to 03:00 which is perfect or you can just enter 03:00.
I now have a problem if a user enters 03;00 as i need this to display 03:00
how can i ensure that all times are in the hh:mm format and not in hh;mm etc.
This needs to auto change on input for anything in column A, except what is the header (A1:A5) although this should not be affected.
Thanks
On your sheets change event you would place the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = 1 And Target.Column = 1 And Target.Row > 5 Then
Target.Value2 = Replace(Target.Value2, ";", ":")
End If
End Sub
Explaining the code... it first checks to make sure that the change isn't on multiple cells (ie paste) and that the change is on column A below Row 5. If it does pass the conditional it simply replaces ; for :.
This does what i require.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim xStr As String
Dim xVal As String
Set rng1 = Range("A:A")
Set rng2 = Range("C:C")
Set rng3 = Range("I:I")
On Error GoTo EndMacro
If Application.Intersect(Target, Union(rng1, rng2, rng3)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Target.Row < 5 Then Exit Sub
Application.EnableEvents = False
With Target
If Not .HasFormula Then
Target.Value = Replace(Target.Value, ";", ":")
Target.Value = Left(Target.Value, 5)
xVal = .Value
Select Case Len(xVal)
Case 1 ' e.g., 1 = 00:01 AM
xStr = "00:0" & xVal
Case 2 ' e.g., 12 = 00:12 AM
xStr = "00:" & xVal
Case 3 ' e.g., 735 = 07:35 AM
xStr = "0" & Left(xVal, 1) & ":" & Right(xVal, 2)
Case 4 ' e.g., 1234 = 12:34
xStr = Left(xVal, 2) & ":" & Right(xVal, 2)
Case 5 ' e.g., 12:45 = 12:45
xStr = Left(xVal, 2) & Mid(xVal, 2, 1) & Right(xVal, 2)
Case Else
Err.Raise 0
End Select
.Value = Format(TimeValue(xStr), "hh:mm")
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
Application.EnableEvents = True
End Sub
Thanks
I have a code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim ltr, rNum, AlphaLtrs
AlphaLtrs = "ABCDEFGHIGKLMNOPQRSTUVWXYZ"
selLtr = Application.RoundUp(Rnd() * 26, 0)
ltr = Mid(AlphaLtrs, selLtr, 1)
rNum = Application.RoundUp(Rnd() * 999999, 0)
ActiveCell.Value = ltr & rNum
Target.Offset(0, 1).Select
End Sub
what I need is, to change the doubleclick function into Enter
and also if possible can I add the value of Column A in to the generated code beginning like Jeans-A545145
This adds a value to any cell that selected in column B, as long as only one cell is selected. Paste it into the code module for that sheet:
EDIT: Not sure if this is what you want, but now only does it if Target cell is empty:
EDIT 2: Woops, found a bug in the IF. If you select more than one cell, it errors on the IF Target.Value = "" part. I separated that into a second IF:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ltr, rNum, AlphaLtrs, selLtr
If Not Intersect(Target, Me.Columns(2)) Is Nothing And _
Target.Cells.Count = 1 Then
If Target.Value = "" Then
AlphaLtrs = "ABCDEFGHIGKLMNOPQRSTUVWXYZ"
selLtr = Application.RoundUp(Rnd() * 26, 0)
ltr = Mid(AlphaLtrs, selLtr, 1)
rNum = Application.RoundUp(Rnd() * 999999, 0)
Target.Value = Me.Range("A" & Target.Row) & "-" & ltr & rNum
End If
End If
End Sub
Perhaps:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim ltr, rNum, AlphaLtrs
AlphaLtrs = "ABCDEFGHIGKLMNOPQRSTUVWXYZ"
selLtr = Application.RoundUp(Rnd() * 26, 0)
ltr = Mid(AlphaLtrs, selLtr, 1)
rNum = Application.RoundUp(Rnd() * 999999, 0)
ActiveCell.Value = ltr & rNum
Target.Offset(0, 1).Select
Application.EnableEvents = True
End Sub