Current script tracks cell changes from cell A1 and counts those changes in cell B1. However it only works when you actively input a number or text and then hit enter in cell A1. I need the formula to work when the A1 cell is referenced from another cell to count the changes.
Option Explicit
Private prevVal As String
Private Sub ToggleButton1_Click()
End Sub
Private Sub Worksheet_Calculate()
If Worksheets("Sheet1").ToggleButton1.Value = True Then
Application.EnableEvents = False
If Me.Range("A1").Value <> prevVal Then
Me.Range("B1").Value = Me.Range("B1").Value + 1
prevVal = Me.Range("A1").Value
End If
End If
Application.EnableEvents = True
End Sub
If the "A1" cell value is the result of a formula, you should use Calculate event. Please, copy this code event in the sheet code module:
Option Explicit
Private prevVal As String
Private Sub Worksheet_Calculate()
Application.EnableEvents = False
If Me.Range("A1").value <> prevVal Then
Me.Range("B1").value = Me.Range("B1").value + 1
prevVal = Me.Range("A1").value
End If
Application.EnableEvents = True
End Sub
Related
The script below triggers every couple milliseconds due to the Worksheet Calculate event and then copies from my Pivot Table to the Chart Helper. Script works great but when it copies the next iteration of data it pastes it after the original data set it just copied.
I need it to continuously paste over the original data set. Example if the original data set copies to A1:A15 I want it to replace A1:A15 not keep A1:A15 then add the new refreshed data set to A16:A30.
I suspect this line is the culprit Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
Private Sub Worksheet_Calculate()
If Not Worksheets("Dashboard").ToggleButton1.Value Then Exit Sub
Dim chPivot As PivotCache
On Error GoTo SafeExit
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each chPivot In ActiveWorkbook.PivotCaches
chPivot.Refresh
Next chPivot
With ThisWorkbook.Sheets("Data Breakdown").PivotTables("PivotTable1").PivotFields("Price").DataRange
ThisWorkbook.Sheets("Chart Helper").Cells(Rows.Count, 1).End(xlUp). _
Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
With ThisWorkbook.Sheets("Data Breakdown").PivotTables("PivotTable1").PivotFields("Cost").DataRange
ThisWorkbook.Sheets("Chart Helper").Cells(Rows.Count, 2).End(xlUp). _
Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End With
SafeExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Assuming your data either gets larger or stays the same size then you just always need to paste data into the exact same cell to overwrite prior pastes.
i.e. replace .Cells(Rows.Count, 1).End(xlUp).Offset(1) with Range("A1")
You also need to separate your with statements. It can become ambiguous which object is being referenced when many are nested. Lastly, remove the column resize. You only need to resize the row here.
Your code could also be cleaned up a little by creating some Worksheet variables
Private Sub Worksheet_Calculate()
If Not Worksheets("Dashboard").ToggleButton1.Value Then Exit Sub
Dim db As Worksheet: Set db = ThisWorkbook.Sheets("Data Breakdown")
Dim ch As Worksheet: Set ch = ThisWorkbook.Sheets("Chart Helper")
Dim chPivot As PivotCache
On Error GoTo SafeExit
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each chPivot In ActiveWorkbook.PivotCaches
chPivot.Refresh
Next chPivot
'Value transfer 'PRICE' to A1
With db.PivotTables("PivotTable1").PivotFields("Price").DataRange
ch.Range("A1").Resize(.Rows.Count).Value = .Value
End With
'Value transfer 'COST' to B1
With db.PivotTables("PivotTable1").PivotFields("Cost").DataRange
ch.Range("B1").Resize(.Rows.Count).Value = .Value
End With
SafeExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
A few issues: Script is linked to a form ctrl button that runs Update Data every minute. This runs Copy Data and copies row A39:T39 and pastes that row in the other sheet. That is the intent. But it doesn't paste right. Need to past in a row not a column starting w/ a time stamp on the other sheet in A2. Stop Recording Data is linked to a form ctrl button to cancel Update Data but that doesn't work either.
Sub UpdateData()
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData"
CopyData
End Sub
Sub CopyData()
Dim sht1 As Worksheet, sht2 As Worksheet, cpyRng As Range, logRng As Long
Application.StatusBar = "Recording Dashboard Started"
Set sht1 = ThisWorkbook.Sheets("Dashboard")
Set sht2 = ThisWorkbook.Sheets("Log")
Set cpyRng = sht1.Range("A39:T39")
logRng = sht2.Cells(2, Columns.Count).End(xlToLeft).Column + 1
sht2.Range("A2") = Now
cpyRng.Copy sht2.Cells(2, logRng)
End Sub
Sub StopRecordingData()
Application.StatusBar = "Recording Dashboard Stopped"
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData", False
End Sub
Put this code into an own module.
To start logging, call StartRecordingData()
and for stopping call StopRecordingData()
Option Explicit
Dim boolLoggingActive As Boolean
Public Sub StartRecordingData()
Application.StatusBar = "Recording Dashboard Started"
boolLoggingActive = True
UpdateData
End Sub
Public Sub StopRecordingData()
Application.StatusBar = "Recording Dashboard Stopped"
boolLoggingActive = False
End Sub
Private Sub UpdateData()
If boolLoggingActive = True Then
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData"
CopyData
End If
End Sub
Private Sub CopyData()
Dim sht1 As Worksheet, sht2 As Worksheet, cpyRng As Range, logRng As Long
Application.StatusBar = "Recording Dashboard Started"
Set sht1 = ThisWorkbook.Sheets("Dashboard")
Set sht2 = ThisWorkbook.Sheets("Log")
Set cpyRng = sht1.Range("A39:T39")
Dim rngLogTargetBeginningCell As Range
Set rngLogTargetBeginningCell = sht2.Rows(sht2.Rows.Count).Columns(1).End(xlUp).Offset(1, 0)
rngLogTargetBeginningCell = Now
Dim rngLastCellSelection As Range
Application.ScreenUpdating = False ' Stop Updating Graphic during data copy
Set rngLastCellSelection = Selection ' remember the last selection because pasting will change the active cell
cpyRng.Copy
rngLogTargetBeginningCell.Offset(0, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False ' Remove the copy area marker
rngLastCellSelection.Select ' reselect the old cell
Application.ScreenUpdating = True ' update graphics again
End Sub
I have a user form with the following code. Basically what it does is If the user selects a title, and clicks commandButton2 which inserts the selected movie title into a titlebox and an array. Now i made another button commandButton3 which the user can select from the titlebox for which title to delete, but i am struggling deleting it from the array that i am building as well. Thanks in advance.
Public SelectedTitles As Variant, ArrCount As Long, EnableEvents As Boolean
Private Sub CommandButton1_Click()
'Done Button
Me.Hide
End Sub
Private Sub CommandButton2_Click()
'User has indicated they want to add the currently selected item to the list
If Not EnableEvents Then Exit Sub
If ArrCount = 0 Then 'First item, create the array
SelectedTitles = Array("")
Else
ReDim Preserve SelectedTitles(UBound(SelectedTitles) + 1) 'Next items, add one more space in the array
End If
'Add the selected title to the array
SelectedTitles(ArrCount) = ComboBox1.Value
ListBox1.AddItem (SelectedTitles(ArrCount))
'Increment the counter
ArrCount = ArrCount + 1
'Reset the checkbox and the combobox
EnableEvents = False
CommandButton2.Value = False
ComboBox1.Value = ""
EnableEvents = True
End Sub
Private Sub CommandButton3_Click()
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i) Then
ListBox1.RemoveItem i
If SelectedTitles() = i Then
SelectedTitles() = "n/a"
End If
ArrCount = ArrCount - 1
End If
Next i
EnableEvents = False
CommandButton3.Value = False
ComboBox1.Value = ""
EnableEvents = True
End Sub
Private Sub CommandButton4_Click()
ListBox1.Clear
Erase SelectedTitles
ArrCount = 0
EnableEvents = False
CommandButton4.Value = False
ComboBox1.Value = ""
EnableEvents = True
End Sub
Private Sub ListBox1_Click()
End Sub
Private Sub UserForm_Initialize()
EnableEvents = True
End Sub
Firt of all, using arrays in VBA can be a real pain. You might consider using ArrayLists instead, which are far more convenient to use. Check this:https://excelmacromastery.com/vba-arraylist/
Assuming your array was an arraylist you could just do you could just do :
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i) Then
ListBox1.RemoveItem i
SelectedTitles.RemoveAt i
End If
Next i
But if you wish to stick to your array you'll have to do something like this :
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i) Then
ListBox1.RemoveItem i
For j = 0 to Ubound(SelectedTitles)-1
If SelectedTitles(j) <> SelectedTitles (i) then
ReDim Preserve TempSelectedTitles(UBound(TempSelectedTitles) + 1)
TempSelectedTitles(j) = SelectedTitles(i)
end if
next J
SelectedTitles = TempSelectedTitle
End If
Next i
I didn't try this code but you got the idea, you will need to rebuild your array without including the selected value in you listbox
Script below currently stores an array and then compares it to an RTD updated array and outputs if there is a change. If there is no change then it will not log the change. Works great, but now I need an output log of the difference if a change occurs rather than output of a changed value in the updated array.
Code in Module 1
Public myArr()
Public Sub
PopulateMyArr()
myArr = Sheet4.Range("I6:I500").Value
End Sub
Code in This Workbook
Private Sub Workbook_Open()
PopulateMyArr
End Sub
Code in Sheet4(BA_Size)
Private Sub ToggleButton1_Click()
End Sub
Private Sub Worksheet_Calculate()
Dim keyCells As Range
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:J500")
If Worksheets("BA_Size").ToggleButton1.Value = True Then
Dim i As Integer
For i = 1 To UBound(myArr)
If keyCells(i, 1).Value <> myArr(i, 1) Then
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
Sheet1.Cells(nextrow, "A").Value = Me.Cells(i + 5, "I").Value
End If
Next i
End If
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
I'm running into an odd issue. I have 2 Userform, at first Userform2 was inside Userform1, but I wasn't able to make it run. After that I made that a Sub in my Module call Userform2 after other once Userform1 is done.
The problem is the Userform2 is a Multiselect Listbox, and I save each selection in an array and when the Userform2 unloads the array seems to be empty.
I have checked for hours many errors like: I have no explicit option on, but the code is pretty short and I have looked for the array within my code and it only appears on the exact parts I wanted it to be.
Neither the public array as variant was a problem, because it is outside the Userform and in the original Module.
I'm from Chile so some variables have names in Spanish and my English might not be so good, I'll do my best to explain my self.
Here is the code:
Global lenarrv
Global Arrver
Global BoxPMData
Global anno
Global PMDATAarray
Global LenPMDArray
Public varfamilia As Variant
Public pampm As Variant
Sub AbrirMaestro(ByVal anno As Variant)
Application.ScreenUpdating = False
UserForm1.Show
UserForm2.Show
Dim Arrver() As Variant
Dim lenarrv As Long
contentosrcontento = 1
lenarrv = UBound(pampm)
For tt = 0 To lenarrv - 1
ReDim Arrver(contentosrcontento)
Arrver(contentosrcontento) = pampm(tt)
contentosrcontento = contentosrcontento + 1
Next tt
lenarrv = UBound(Arrver)
Inputbox_PMDATA anno
End Sub
Here comes the Userforms:
Private Sub UserForm_Activate()
Me.StartUpPosition = 1
Me.Left = Application.Left + Application.Width - Me.Width - 400
End Sub
Private Sub UserForm_Initialize()
Dim listaitems As Variant
Workbooks("MAESTROS.xlsx").Activate
numerofilas = Workbooks("MAESTROS.xlsx").Sheets("VERTICALES").Cells(2, 1).End(xlDown).Row
listaitems = Workbooks("MAESTROS.xlsx").Sheets("VERTICALES").Range("A2:A" & numerofilas)
listaitems = Application.WorksheetFunction.Transpose(listaitems)
For h = 1 To numerofilas - 1
ListBox1.AddItem listaitems(h)
Next h
Workbooks("MAESTROS.xlsx").Close False
End Sub
Public Sub CommandButton1_Click()
Dim i As Integer
Dim count As Integer
count = 1
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ReDim pampm(count)
pampm(i) = ListBox1.List(i)
count = count + 1
End If
Next i
Unload UserForm2
End Sub
Here is UserForm1 :
Private Sub UserForm_Activate()
Me.StartUpPosition = 1
Me.Left = Application.Left + Application.Width - Me.Width - 400
End Sub
Private Sub UserForm_Initialize()
Dim ListItems As Variant
MsgBox ("Elegir el archivo MAESTRO")
Master = Application.GetOpenFilename(MultiSelect:=False)
isBool = VarType(Master) = vbBoolean
If isBool Then If Not Master Then End
Application.ScreenUpdating = False
Set abrirlibro = Workbooks.Open(Master)
numrows = abrirlibro.Worksheets("MASTERFAMILIA").Cells(2, 2).End(xlDown).Row
ListItems = abrirlibro.Worksheets("MASTERFAMILIA").Range("B2:B" & numrows)
ListItems = Application.WorksheetFunction.Transpose(ListItems)
For i = 1 To numrows - 1
ComboBox1.AddItem ListItems(i) ' populate the listbox
Next i
'abrirlibro.Close False
'Set abrirlibro = Nothing
End Sub
Public Sub CommandButton1_Click()
varfamilia = ComboBox1.value
Unload UserForm1
End Sub
I can't past the full code since there are more than 2k lines..
Any help is welcome.
Greetings!
you have to change
Public pampm As Variant
to
Public pampm() As Variant
and
ReDim pampm(count)
to
ReDim Preserve pampm(count)