I'm trying to create a simple counting sheet which has 5 buttons to increment the count of each field, a 'New Round' Button to start a new round in a new column (R2 and so forth) and Clear button which clears all the counts and start over again from Round1
So far I've come up with this code:
Function rngLastRound() As Range
With Range("2:2").Cells(1, Columns.Count).End(xlToLeft)
Set rngLastRound = .EntireColumn
End With
End Function
Sub IncrementCurrentRoundOfRow(N As Long)
With rngLastRound
.Cells(N, 1).Value = Val(CStr(.Cells(N, 1).Value)) + 1
End With
End Sub
Sub IncrementCurrentRoundA()
Call IncrementCurrentRoundOfRow(3)
End Sub
Sub IncrementCurrentRoundB()
Call IncrementCurrentRoundOfRow(4)
End Sub
Sub IncrementCurrentRoundC()
Call IncrementCurrentRoundOfRow(5)
End Sub
Sub IncrementCurrentRoundD()
Call IncrementCurrentRoundOfRow(6)
End Sub
Sub IncrementCurrentRoundE()
Call IncrementCurrentRoundOfRow(7)
End Sub
Sub NewRound()
With rngLastRound.Offset(0, 1)
.Cells(2, 1).Value = "R" & (.Column - 1)
.Cells(3, 1).Resize(5, 1).Value = 0
End With
End Sub
Sub Clear()
Range("B2", rngLastRound).ClearContents
Call NewRound
End Sub
The code works fine, but it clears the entire columns so that means the totals and grand total also gets cleared. How do I prevent this from happening by not specifying .EntireColumn attribute and instead a specific range?
Thanks
A Game
Option Explicit
Function rngLastRound() As Range
With Range("2:2").Cells(Columns.Count).End(xlToLeft)
Set rngLastRound = .Resize(6)
End With
End Function
Sub IncrementCurrentRoundOfRow(N As Long)
With rngLastRound
.Cells(N).Value = Val(CStr(.Cells(N).Value)) + 1
End With
End Sub
Sub IncrementCurrentRoundA()
Call IncrementCurrentRoundOfRow(2)
End Sub
Sub IncrementCurrentRoundB()
Call IncrementCurrentRoundOfRow(3)
End Sub
Sub IncrementCurrentRoundC()
Call IncrementCurrentRoundOfRow(4)
End Sub
Sub IncrementCurrentRoundD()
Call IncrementCurrentRoundOfRow(5)
End Sub
Sub IncrementCurrentRoundE()
Call IncrementCurrentRoundOfRow(6)
End Sub
Sub NewRound()
With rngLastRound.Offset(, 1)
.Cells(1).Value = "R" & (.Column - 1)
.Cells(2).Resize(5).Value = 0
End With
End Sub
Sub Clear()
Range("B2", rngLastRound).ClearContents
Call NewRound
End Sub
Try changing the line Set rngLastRound = .EntireColumn in the rngLastRound () function to Set rngLastRound = Application.Intersect (.EntireColumn, Rows ("2: 7"))
Related
Trying to clear the contents if the cell equals 100 after the email is sent to prevent additional emails going out. I'm not wishing to clear all the range. Only if it = 100.
Private Sub Worksheet_Calculate()
If WorksheetFunction.CountIf(Range("I36:I44"), 100) Then
Call Mail_small_Text_Outlook
Range("I36:I44").ClearContents
End If
End Sub
You don't need a loop
Private Sub Worksheet_Calculate()
Dim pos As Variant
pos = Application.Match(100, Range("I36:I44"), 0)
If IsNumeric(pos) Then
Call Mail_small_Text_Outlook
Range("I36:I44").Cells(pos).Value = ""
End If
End Sub
I have a data in column B which is dynamic ( cities can be in any order) , what I am looking is for a VBA code to fill color in the rectangle shape ( I have renamed rectangle shapes to corresponding city names). based on the color of corresponding city.
This is sample list, and actual data can be long, Hence was looking for an automated script to do this task.
Please, try the next approach. It will use a class, able to trigger the interior color change:
Insert a class module, name it "clsCelColorCh", copy and place the next code:
Option Explicit
Private WithEvents cmBar As Office.CommandBars
Private cellsCountOK As Boolean, arrCurColor(), arrPrevColor(), sCellAddrss() As String
Private sVisbRngAddr As String, i As Long, objSh As Worksheet, cel As Range, rngBB As Range
Public Sub ToSheet(sh As Worksheet)
Set objSh = sh
End Sub
Public Sub StartWatching()
Set cmBar = Application.CommandBars
End Sub
Private Sub Class_Initialize()
cellsCountOK = False
End Sub
Private Sub cmBar_OnUpdate()
If Not ActiveSheet Is objSh Then Exit Sub
Set rngBB = Intersect(ActiveWindow.VisibleRange, objSh.Range("B:B"))
If rngBB Is Nothing Then Exit Sub
If sVisbRngAddr <> rngBB.Address And sVisbRngAddr <> "" Then
Erase sCellAddrss: Erase arrCurColor: Erase arrPrevColor
sVisbRngAddr = "": cellsCountOK = False
End If
i = -1
On Error Resume Next
For Each cel In rngBB.cells
ReDim Preserve sCellAddrss(i + 1)
ReDim Preserve arrCurColor(i + 1)
sCellAddrss(i + 1) = cel.Address
arrCurColor(i + 1) = cel.Interior.Color
If arrPrevColor(i + 1) <> arrCurColor(i + 1) Then
If cellsCountOK = True Then 'call the pseudo event Sub
CallByName objSh, "Cell_ColorChange", VbMethod, cel
arrPrevColor(i + 1) = arrCurColor(i + 1)
End If
End If
i = i + 1
If i + 1 >= rngBB.cells.count Then
cellsCountOK = True
ReDim Preserve arrPrevColor(UBound(arrCurColor))
arrPrevColor = arrCurColor
End If
arrPrevColor(i + 1) = arrCurColor(i + 1)
Next
On Error GoTo 0
sVisbRngAddr = rngBB.Address
End Sub
Copy the next code in the sheet to monitor color changes code module (right click on the sheet name and choose View Code):
Option Explicit
Private ColorChEventMonitor As clsCelColorCh
Public Sub Cell_ColorChange(Target As Range)
Dim sh As Shape
On Error Resume Next
Set sh = Me.Shapes(Target.Value)
On Error GoTo 0
If Not sh Is Nothing Then
sh.Fill.ForeColor.RGB = Target.Interior.Color
Else
MsgBox "No shape named as """ & Target.Value & """ in this sheet..."
End If
End Sub
Private Sub Worksheet_Activate()
StartEventWatching
End Sub
Private Sub Worksheet_Deactivate()
StopEventWatching
End Sub
Private Sub StartEventWatching()
Set ColorChEventMonitor = New clsCelColorCh
ColorChEventMonitor.ToSheet Me
ColorChEventMonitor.StartWatching
End Sub
Private Sub StopEventWatching()
Set ColorChEventMonitor = Nothing
End Sub
Deactivate the sheet in discussion (go on a different sheet) and go back. I this way, the sheet Activate event starts the color change monitoring.
It does it for color changes in column "B:B".
In order to see it working, of course, there must be so many shapes as records in column "B:B", named exactly like the cells value. Anyhow, if a cell value does not match any shape, no error will be raised, a message mentioning that a correspondent shape does not exist will appear.
The pseudo event is triggered when you select another cell. Sometimes, it is triggered only by simple changing the color, but not always...
Please, test it and send some feedback.
I have been running with this problem for a while, I leave the sample file code, written below, the thing is that when I run it on the computer from where I work at, in the Sub CommandButton1_Click() when it starts to run the 3 lines after the commented line with i=1, each line starts the ListBox1_Click() and resets the textbox values making a mess, how I overcome this?, by using a conditional so it doesn't overwrite anything when working in other functions.
I want to know if anyone had before this problem, and know how to fix it. Running it from my personal computer is not an option, but the if conditional makes the thing, however I don't think is the optimal way to solve the problem.
Private Sub CommandButton1_Click()
Dim Ultima_Fila As Integer
Ultima_Fila = Sheets("Sheet1").Range("E2") + 1
Sheets("Sheet1").Range("A" & Ultima_Fila).EntireRow.Insert
Sheets("Sheet1").Range("A" & Ultima_Fila) = Sheets("Sheet1").Range("E2")
'i=1 'Required i to be 1 in order to avoid the code to jump and read the textbox from the ListBox1_Click
Sheets("Sheet1").Range("B" & Ultima_Fila) = TextBox1.Value
Sheets("Sheet1").Range("C" & Ultima_Fila) = TextBox2.Value
Sheets("Sheet1").Range("D" & Ultima_Fila) = TextBox3.Value
'i=0 Restarts i value
End Sub
Private Sub ListBox1_Click()
'If i = 0 Then 'When the sub is initialized directly from the listbox click it stores the values displayed on the textboxes
TextBox1 = ListBox1.List(ListBox1.ListIndex, 1)
TextBox2 = ListBox1.List(ListBox1.ListIndex, 2)
TextBox3 = ListBox1.List(ListBox1.ListIndex, 3)
'End If 'This conditional jumps the following instruction when it is reached from the CommandButton1_Click
End Sub
Private Sub UserForm_Activate()
With ListBox1
.ColumnCount = 4
.RowSource = "Table1"
.ColumnHeads = True
End With
End Sub
Please don't be disheartened by the changes I made to your code. In essence it remains the same. I just wanted to be sure that what I tell you is 100% correct:-
The ListBox1_Click event is triggered by a change to ListBox1.ListIndex. My code below contains such a change and disables the event it causes in the way you already found. The explanation for the procedure being fired on another computer is that the ListIndex is changed. Perhaps the code being run there is different and perhaps it's a Mac or Google sheets, in short, a non-Microsoft engine interpreting the same code.
However, you may still like my code because it has some features that yours didn't have. Please try it. It should run on both systems.
Option Explicit
Private DisableListBoxEvents As Boolean
Private Sub UserForm_Activate()
' 263
With ListBox1
.ColumnCount = 4
.RowSource = "Table1"
.ColumnHeads = True
End With
End Sub
Private Sub CommandButton1_Click()
' 263
Dim Ultima_Fila As Integer
Dim Tbx As Control
Dim i As Integer
With Worksheets("Sheet1")
Ultima_Fila = .Range("E2").Value + 1
With .ListObjects(1)
' inserts a table row before table row Ultima_Fila
' Omit the number to append a row.
' To convert sheet row to table row enable this line:-
' Ultima_Fila = Ultima_Fila - .Range.Row - 1
With .ListRows.Add(Ultima_Fila).Range
For i = 1 To 3
Set Tbx = Me.Controls("TextBox" & i)
.Cells(i + 1).Value = Tbx.Value
Tbx.Value = ""
Next i
End With
End With
End With
With ListBox1
DisableListBoxEvents = True
.RowSource = "Table1"
.ListIndex = -1
DisableListBoxEvents = False
End With
End Sub
Private Sub ListBox1_Click()
' 263
Dim i As Integer
If DisableListBoxEvents Then Exit Sub
With ListBox1
For i = 1 To 3
Me.Controls("TextBox" & i).Value = .List(.ListIndex, i)
Next i
End With
End Sub
I am working on an excel dashboard and need to display 2 specific worksheets in the workbook and switch between tabs with an interval of 30 seconds per tab and then return to the first tab and repeat.
I found a macro that is similar to what I need, Excel - Automated Worksheet Switching Loop, however I am trying to only show 2 specific worksheets and not all worksheets in the workbook.
Here is the code that I am using:
Sub StartSlideShow()
Application.OnTime Now + TimeValue("00:00:30"), "ShowNextSheet"
End Sub
Sub ShowNextSheet()
Dim lastIndex As Integer, nextShtIndex As Integer
lastShtIndex = Worksheets.Count
nextShtIndex = ActiveSheet.Index + 1
If nextShtIndex <= lastShtIndex Then
Worksheets(nextShtIndex).Select
StartSlideShow
Else
Worksheets(1).Select
StartSlideShow
End If
End Sub
Something like this:
Sub SlideToOne()
Application.OnTime Now + TimeValue("00:00:30"), "ShowFirstSheet"
End Sub
Sub SlideToTwo()
Application.OnTime Now + TimeValue("00:00:30"), "ShowSecondSheet"
End Sub
Sub ShowFirstSheet()
Worksheets(1).Select
SlideToTwo
End Sub
Sub ShowSecondSheet()
Worksheets(2).Select
SlideToOne
End Sub
Is it possible to use a listbox to change the order of rows in a worksheet? I have searched the Web for about an hour without ressults. I am using the following code for the task:
Private Sub UserForm_Initialize()
ListBox1.RowSource = "Sheet1!A1:A15"
End Sub
Option Explicit
Const UP As Integer = -1
Const DOWN As Integer = 1
Private Sub SpinButton1_SpinUp()
If Me.ListBox1.ListCount > 1 Then
Call MoveListItem(UP, Me.ListBox1)
End If
End Sub
Private Sub SpinButton1_SpinDown()
If Me.ListBox1.ListCount > 1 Then
Call MoveListItem(DOWN, Me.ListBox1)
End If
End Sub
Private Sub MoveListItem(ByVal intDirection As Integer, _
ByRef ListBox1 As ListBox)
Dim intNewPosition As Integer
Dim strTemp As String
intNewPosition = ListBox1.ListIndex + intDirection
strTemp = ListBox1.List(intNewPosition)
If intNewPosition > -1 _
And intNewPosition < ListBox1.ListCount Then
'Swap listbox items
ListBox1.List(intNewPosition) = ListBox1.Value
ListBox1.List(intNewPosition - intDirection) = strTemp
ListBox1.Selected(intNewPosition) = True
End If
End Sub
Hope somone can give me a hint!
UPDATE!!
What i want is, if I for example have these values in a column in my worksheet:
week1
week2
week3
week4
Then I would like to re-arrenge the order of these values with the SpinButton in the ListBox;
week2
week4
week1
week3
You most certainly can do that!
Here is a quick code that does this in general, I will leave it to you to place this where it is needed:
For i = 0 To ListBox1.ListCount - 1
ActiveWorkbook.Sheets("Sheet1").Range("A" & CStr(i + 1)).Value = ListBox1.List(i)
Next i
You'll probably need to change what is inside the for loop to better reflect your own code. For writing to a specific range just add whatever starting row number you want!