I want to enable both of these worksheet_change event procedures in same sheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, V As Variant, N As Long
Set r = Intersect(Range("H6"), Target)
If r Is Nothing Then Exit Sub
V = r(1).Value
Application.EnableEvents = False
N = Cells(Rows.Count, "K").End(xlUp).Row
If IsEmpty(Range("K11").Value) = True Then
Cells(N + 10, 11).Value = V
Else
Cells(N + 1, 11).Value = V
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, V As Variant, N As Long
Set r = Intersect(Range("J6"), Target)
If r Is Nothing Then Exit Sub
V = r(1).Value
Application.EnableEvents = False
N = Cells(Rows.Count, "P").End(xlUp).Row
If IsEmpty(Range("K16").Value) = True Then
Cells(N + 10, 16).Value = V
Else
Cells(N + 1, 16).Value = V
End If
Application.EnableEvents = True
End Sub
Combine them into one event. You can replace my msgbox code with what you want to happen when a particular cell is triggered.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r1 As Range
Dim r2 As Range, V As Variant, N As Long
Set r1 = Range("H6")
Set r2 = Range("J6")
If Application.Intersect(Target, Union(r1, r2)) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Address(0, 0) = "H6" Then
MsgBox "H6 triggered" 'your H6 code
ElseIf Target.Address(0, 0) = "J6" Then
MsgBox "J6 triggered" 'your J6 code
Else
MsgBox "Unexpected error"
End If
Application.EnableEvents = True
End Sub
With your code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r1 As Range
Dim r2 As Range, V As Variant, N As Long
Set r1 = Range("H6")
Set r2 = Range("J6")
If Application.Intersect(Target, Union(r1, r2)) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Address(0, 0) = "H6" Then
V = r1(1).Value
N = Cells(Rows.Count, "K").End(xlUp).Row
If IsEmpty(Range("K11").Value) = True Then
Cells(N + 10, 11).Value = V
Else
Cells(N + 1, 11).Value = V
End If
ElseIf Target.Address(0, 0) = "J6" Then
V = r2(1).Value
N = Cells(Rows.Count, "P").End(xlUp).Row
If IsEmpty(Range("K16").Value) = True Then
Cells(N + 10, 16).Value = V
Else
Cells(N + 1, 16).Value = V
End If
Else
MsgBox "Unexpected error"
End If
Application.EnableEvents = True
End Sub
Related
First time VBA coder here, so I'm not quite sure where to start.
I'm creating a "quiz" wherein a macro selects a random empty cell within a set range (C9:014). The user then types something into the cell and presses Enter. Then, the macro selects another empty cell within the set range (C9:O14). The user again types something into the selected cell and presses Enter. This process repeats until all 78 cells in the range have been filled by the user.
I suspect that some sort of Do Until loop is involved.
Does anyone have any ideas on how to do this?
Thanks so much guys.
Welcome on board!
Using this code:
The game starts once you activate the sheet.
The player can't change the selection made by the code.
First, add this code to worksheet's Module (in worksheet code pane (right-click on the tab and select "View code") put the following):
Private Used_Range As Range, Quiz_Range As Range, ThisCell As Range, PreventSelect As Boolean
Private Sub Worksheet_Activate()
FreshStart
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long, nMax As Long
OnError GoTo ex
Application.EnableEvents = False
If Quiz_Range Is Nothing Then FreshStart
If Not Used_Range Is Nothing Then
If Used_Range.Address = Quiz_Range.Address Then
If MsgBox("Game Over!" & Chr(10) & "Do you want to start over?", vbYesNo) = vbYes Then
FreshStart
Else
GoTo ex
End If
End If
End If
nMax = Quiz_Range.Cells.Count
n = RandBetween(1, nMax)
If Used_Range Is Nothing Then
Set ThisCell = Quiz_Range.Cells(n)
Set Used_Range = ThisCell
Else
Do Until Intersect(Quiz_Range.Cells(n), Used_Range) Is Nothing
n = n + 1
If n > nMax Then n = 1
Loop
Set ThisCell = Quiz_Range.Cells(n)
Set Used_Range = Union(Used_Range, ThisCell)
End If
Quiz_Range.Cells(n).Select
ex:
Application.EnableEvents = True
PreventSelect = False
End Sub
Function RandBetween(MinInt As Long, MaxInt As Long) As Long
RandBetween = Int((MaxInt - MinInt + 1) * Rnd + MinInt)
End Function
Sub FreshStart()
Set Used_Range = Nothing
Set Quiz_Range = Range("C9:O14")
Quiz_Range.ClearContents
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If PreventSelect Then
ThisCell.Select
MsgBox "You can't select another cell!"
End If
PreventSelect = True
Application.EnableEvents = True
End Sub
Note: This random selector selects the next unused cell if the output of the Rnd function refers to a used cell.
Edit #1
Using the randomizing collection method by #HTH, the code can be much better:
Private coll As Collection, Quiz_Range As Range, ThisCell As Range, PreventSelect As Boolean
Private Sub Worksheet_Activate()
FreshStart
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long, nMax As Long, m As Long
OnError GoTo ex
Application.EnableEvents = False
If Quiz_Range Is Nothing Then FreshStart
If coll.Count = 0 Then
If MsgBox("Game Over!" & Chr(10) & "Do you want to start over?", vbYesNo) = vbYes Then
FreshStart
Else
GoTo ex
End If
End If
n = Int(1 + Rnd * (coll.Count))
Quiz_Range.Cells(coll(n)).Select
coll.Remove n
ex:
Application.EnableEvents = True
PreventSelect = False
End Sub
Sub FreshStart()
Set Quiz_Range = Range("C9:F14")
SetColl Quiz_Range
Quiz_Range.ClearContents
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If PreventSelect Then
ThisCell.Select
MsgBox "You can't select another cell!"
End If
PreventSelect = True
Application.EnableEvents = True
End Sub
Sub SetColl(rng As Range)
Set coll = New Collection
Dim i As Long
For i = 1 To rng.Count
coll.Add i
Next
End Sub
in worksheet code pane (right clik on the tab and select "View code") put the following
Option Explicit
Dim quizRng As Range
Dim coll As Collection
Dim i As Long
Private Sub Worksheet_Change(ByVal Target As Range)
If Not quizRng Is Nothing Then If WorksheetFunction.CountBlank(quizRng) > 0 Then SelectCell Else MsgBox "game over"
End Sub
Sub Start()
Set quizRng = Range("C9:O14")
With quizRng
SetColl .Cells
.ClearContents
i = 0
End With
End Sub
Sub SelectCell()
Dim n As Long
With quizRng
If coll.Count = 0 Then Exit Sub
i = i + 1
n = Int(1 + Rnd * (coll.Count))
.Cells(coll(n)).Select
coll.Remove n
End With
End Sub
Sub SetColl(rng As Range)
Set coll = New Collection
Dim i As Long
For i = 1 To rng.Count
coll.Add i
Next
End Sub
Then add a Button to your sheet and assign it the Start macro
The user will have to click the button to start the game and then just write into cells that are progressiveley selected by the code until the "game over" message
Edit
alternatively to a button, as in #AbdallahEl-Yaddak answer, you could have it al started by the sheet activating just adding the following code
Private Sub Worksheet_Activate()
MsgBox "Start of the game!"
Start
End Sub
Edit 2
changed
.Cells(m \ .Columns.Count + IIf(m Mod .Columns.Count = 0, 0, 1), IIf(m Mod .Columns.Count = 0, .Columns.Count, m Mod .Columns.Count))
to
.Cells(coll(n)).Select
thanks to #AbdallahEl-Yaddak
Give the name of the range (on which you will play the game) in cell A1.
Sub quiz()
Dim ws As Worksheet, target As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set target = ws.Range(ws.Range("A1").Value)
Total = target.Rows.Count * target.Columns.Count
random = Rnd(Total)
For Each cell In target
If cell.Value = "" Then
cell.Select
If cell.Row * cell.Column = random Then
Exit For
End If
End If
Next cell
End Sub
This assumes that all the cells in the block are initially empty:
Sub JustaGame()
Dim rng As Range, arr(1 To 78) As Variant
Set rng = Range("C9:O14")
i = 1
For Each r In rng
arr(i) = r.Address(0, 0)
i = i + 1
Next r
Call Shuffle2(arr)
For i = 1 To 78
addy = arr(i)
v = Application.InputBox(Prompt:="Please enter a value for cell " & addy, Type:=2)
Range(addy) = v
Next i
End Sub
Public Sub Shuffle2(InOut() As Variant)
Dim o As Object, oc As Long, i As Long, io
Dim j As Long, k As Long
Hi = UBound(InOut)
Low = LBound(InOut)
ReDim helper(Low To Hi) As Variant
Randomize
Set o = CreateObject("System.Collections.ArrayList")
For Each io In InOut
o.Add io
Next io
j = Low
oc = o.Count - 1
For i = 1 To oc
k = Int((o.Count - 1 - 0 + 1) * Rnd() + 0)
helper(j) = o.Item(k)
j = j + 1
o.RemoveAt k
Next i
helper(j) = o.Item(0)
For j = Low To Hi
InOut(j) = helper(j)
Next j
Set o = Nothing
End Sub
Note:
arr() is a complete list of the addresses in the block
Shuffle2() creates a random permutation of that list
the code fills the cells in the random order specified above
EDIT#1:
This version of Shuffle() does not need ArrayLists:
Public Sub Shuffle(InOut() As Variant)
Dim i As Long, j As Long
Dim tempF As Double, Temp As Variant
Hi = UBound(InOut)
Low = LBound(InOut)
ReDim helper(Low To Hi) As Double
Randomize
For i = Low To Hi
helper(i) = Rnd
Next i
j = (Hi - Low + 1) \ 2
Do While j > 0
For i = Low To Hi - j
If helper(i) > helper(i + j) Then
tempF = helper(i)
helper(i) = helper(i + j)
helper(i + j) = tempF
Temp = InOut(i)
InOut(i) = InOut(i + j)
InOut(i + j) = Temp
End If
Next i
For i = Hi - j To Low Step -1
If helper(i) > helper(i + j) Then
tempF = helper(i)
helper(i) = helper(i + j)
helper(i + j) = tempF
Temp = InOut(i)
InOut(i) = InOut(i + j)
InOut(i + j) = Temp
End If
Next i
j = j \ 2
Loop
End Sub
In the main program, change:
Call Shuffle2(arr)
to:
Call Shuffle(arr)
I found this in this site, write it by Dan Donoghue
Sub BoldTags()
Dim X As Long, BoldOn As Boolean
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(ActiveCell.Text)
If UCase(Mid(ActiveCell.Text, X, 3)) = "<B>" Then
BoldOn = True
ActiveCell.Characters(X, 3).Delete
End If
If UCase(Mid(ActiveCell.Text, X, 4)) = "</B>" Then
BoldOn = False
ActiveCell.Characters(X, 4).Delete
End If
ActiveCell.Characters(X, 1).Font.Bold = BoldOn
Next
End Sub
I don't know anything about coding or magic or this.
This will do what you want:
Sub BoldTags()
Dim rng As Range, X As Long, BoldOn As Boolean
' This works on a selection of cells, if you want it on a full column comment out the next line and uncomment the one below.
For Each rng In Selection
'For Each rng In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(rng.Text)
If UCase(Mid(rng.Text, X, 3)) = "<B>" Then
BoldOn = True
rng.Characters(X, 3).Delete
End If
If UCase(Mid(rng.Text, X, 4)) = "</B>" Then
BoldOn = False
rng.Characters(X, 4).Delete
End If
rng.Characters(X, 1).Font.Bold = BoldOn
Next
Next
End Sub
Just loop over the cells in the activecell's column:
Sub BoldTags(r As Range)
Dim X As Long, BoldOn As Boolean
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(r.Text)
If UCase(Mid(r.Text, X, 3)) = "<B>" Then
BoldOn = True
r.Characters(X, 3).Delete
End If
If UCase(Mid(r.Text, X, 4)) = "</B>" Then
BoldOn = False
r.Characters(X, 4).Delete
End If
r.Characters(X, 1).Font.Bold = BoldOn
Next
End Sub
Sub dural()
Dim rng As Range, r As Range
Set rng = Intersect(ActiveCell.EntireColumn, ActiveSheet.UsedRange)
For Each r In rng
Call BoldTags(r)
Next r
End Sub
NOTE:
The Call is not really necessary
Make sure the list does not contain empties.
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
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
I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas
Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub
You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub