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
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
This is code the internet and I came up with. Please could you tell me what I’m doing wrong? I keep getting an error that says “can’t use a loop without a do”
Sub additions ()
Range(“BI1”) = “Comments”
Range(“V2”).Select
Do until IsEmpty(ActiveCell)
If (Range(ActiveCell) = “DM”) Then
ActiveCell.Offset(0,39).Select
Range(ActiveCell) = “Developed Markets”
ActiveCell.Offset(1,-39).Select
End If
Loop
End Sub
Add String to One Column If Another String in Another Column
Option Explicit
Sub Additions()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range
Set srg = ws.Range("V2", ws.Cells(ws.Rows.Count, "V").End(xlUp))
Dim drg As Range: Set drg = srg.EntireRow.Columns("BI")
ws.Range("BI1").Value = "Comments"
Dim sCell As Range
Dim r As Long
For Each sCell In srg.Cells
r = r + 1
If CStr(sCell.Value) = "DM" Then ' is a match
drg.Cells(r).Value = "Developed Markets"
'Else ' is not a match; do nothing
End If
Next sCell
MsgBox "Additions finished.", vbInformation
End Sub
I am building a patient database. I have code that checks for changes in a specific column. if data in that column reaches a certain range, i make it send an email. Currently when i manually update the column the program works flawlessly, but when i have a date based formula update it - the macro doesn't seem to recognize it.
What could the problem be?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 22 Then Exit Sub
Dim rng As Range
For Each rng In Range("V1:V14")
If (rng.Value < 5 And rng.Value > 1) Then
Call mymacro(rng.Address)
End If
Next rng
End Sub
Private Sub mymacro(theValue As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"The patient that is due is in cell: " & theValue
On Error Resume Next
With xOutMail
.To = "email#hotmail.com"
.CC = ""
.BCC = ""
.Subject = "Upcoming Patient"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
the formula that updates the column is
=IF(P7<>"",(P7-TODAY()),"")
How do I identify all the selected checkboxes in a frame in a user form and assign them to an array so that I can either/both: duplicate the selected checkboxes in one or more other frames & use the array to fill out spreadsheet cells?
Kind of a two-part question, but I think they go hand-in-hand (I'm not sure). I have a userform with multiple frames, and a lot of checkboxes inside each (SS) - I have a standard naming convention for all of them (explained bottom).
I will need to identify which checkboxes are selected (and the selection in the comboboxes) so I can put all that into a spreadsheet. I also will need the option for the user to copy all the selected checkboxes (and the selection in the comboboxes) from one frame to one to three of the other frames if s/he wants to. I have a "Copy" button that initializes a short userform to select which frame to copy from and which frame(s) to copy to. (For example: the ability to copy all the selections from the "Alpha Antennas" frame to one or more of "Beta Antennas" frame, "Gamma Antennas" frame, "Delta Antennas" frame.) Really stuck on what to do in the main form once I get that? I think one array will get me the two functions I need (copying one frame to another and filling out the spreadsheet) - but I don't know the next step. Any help?
Some code/naming/SS:
The command button that loads the main form:
Sub CreateADS()
Dim oneForm As Object
'==========================================================
'On Error GoTo ErrHandler 'Trying to catch errors - will input more down there, later
ADSinputform.Show
For Each oneForm In UserForms
Unload oneForm
'Unload ADSinputform
Next oneForm
End Sub
The main Userform beginning code:
Dim myCheckBoxes() As clsUFCheckBox
Private Sub UserForm_Activate()
'======================================================
'couple pre-initialization things here
'======================================================
End Sub
Private Sub UserForm_Initialize()
Dim chBox As Control
Dim comboBox As Control
Dim arrFreq() As String
Dim i As Long
Dim siteName As String
Dim ctrl As Object, pointer As Long
ReDim myCheckBoxes(1 To Me.Controls.Count)
For Each ctrl In Me.Controls
If TypeName(ctrl) = "CheckBox" Then
pointer = pointer + 1
Set myCheckBoxes(pointer) = New clsUFCheckBox
Set myCheckBoxes(pointer).aCheckBox = ctrl
End If
Next ctrl
ReDim Preserve myCheckBoxes(1 To pointer)
'Use the Split function to create two zero based one dimensional arrays.
arrFreq = Split("Unused|GSM,850|GSM,1900|UMTS,850|UMTS,1900|CDMA,850|LTE,700|LTE,850|LTE,1900|LTE,2100|LTE,2300", "|")
For Each comboBox In ADSinputform.Controls
If TypeOf comboBox Is MSForms.comboBox Then
For i = 0 To UBound(arrFreq)
'Use .List property to write array data to all the comboBoxes
comboBox.List = arrFreq
Next i
End If
Next
MsgBox "This pops up at the end of initialization"
End Sub
Private Sub cmdCopy_Click()
Dim chkBox As Control
Dim cmbBox As Control
Dim frmSource As MSForms.Frame
'Dim frmSource As String
Dim valSectCopy1 As String 'to validate that a sector is filled in
Dim valSectCopy2 As String 'to validate that an antenna is filled in
Dim valPortCopy As String 'to validate that a port is filled in
Set frmSource = SectorsFrame
valSectCopy1 = ""
valSectCopy2 = ""
valPortCopy = ""
For Each chkBox In frmSource.Controls 'Sector-level frame
If TypeName(chkBox) = "CheckBox" And chkBox.Value = True Then
valSectCopy1 = chkBox.Tag
valSectCopy2 = valSectCopy1
Set frmSource = Controls(valSectCopy1)
Exit For
End If
Next chkBox
If valSectCopy1 <> "" Then
For Each chkBox In frmSource.Controls 'Antenna-level frame
If TypeName(chkBox) = "CheckBox" And chkBox.Value = True Then
valSectCopy2 = chkBox.Tag
valPortCopy = valSectCopy2
Set frmSource = Controls(valSectCopy2)
Exit For
End If
Next chkBox
Else
GoTo NoSource
End If
If valSectCopy2 <> valSectCopy1 Then
For Each cmbBox In frmSource.Controls 'Port-level frame
If TypeName(cmbBox) = "ComboBox" And cmbBox.Value <> "Frequency" Then
valPortCopy = cmbBox.Value
Exit For
End If
Next cmbBox
Else
GoTo NoSource
End If
If valSectCopy2 = valPortCopy Then
GoTo NoSource
End If
CopySector.Show
If CopySector.destSectCopy <> "" And CopySector.srcSectCopy <> "" Then
MsgBox "Copying the " & CopySector.srcSectCopy & _
" sector to " & CopySector.destSectCopy & " sector(s)."
Unload CopySector
Exit Sub
Else
Exit Sub
End If
NoSource:
MsgBox "You have not filled in a sector to copy." & vbCrLf & _
"Please fill out sector info for at least one sector and try again."
Exit Sub
End Sub
The questionnaire userform code:
Public srcSectCopy As String
Public destSectCopy As String
Private Sub cmdCopy_Click()
Dim optBtn As Control
Dim chkBox As Control
srcSectCopy = ""
destSectCopy = ""
For Each optBtn In Me.Controls
If TypeName(optBtn) = "OptionButton" Then
If optBtn.Value = True Then
srcSectCopy = optBtn.Tag
End If
End If
Next optBtn
If srcSectCopy = "" Then
MsgBox "You have not selected a sector to copy." & vbCrLf & _
"Please select a sector to copy from and try again."
Exit Sub
End If
For Each chkBox In Me.Controls
If TypeName(chkBox) = "CheckBox" Then
If chkBox.Value = True Then
If destSectCopy = "" Then
destSectCopy = chkBox.Tag
Else
destSectCopy = destSectCopy & ", " & chkBox.Tag
End If
End If
End If
Next chkBox
If destSectCopy = "" Then
MsgBox "You have not selected any sectors to copy to." & vbCrLf & _
"Please select one or more sectors to be duplicated and try again."
Exit Sub
End If
Msg = "this will copy the " & srcSectCopy & _
" sector to " & destSectCopy & " sector(s)." & vbCrLf & _
"Do you want to continue with the operation?"
Ans = MsgBox(Msg, vbQuestion + vbYesNo)
Select Case Ans
Case vbYes
Me.Hide
Case vbNo
Exit Sub
End Select
End Sub
Private Sub UserForm_Initialize()
End Sub
Private Sub AlphaSect_OptBtn_Change()
Select Case (AlphaSect_OptBtn.Value)
Case True: AlphaSect_CheckBox.Enabled = False
AlphaSect_CheckBox.Value = False
Case False: AlphaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub BetaSect_OptBtn_Change()
Select Case (BetaSect_OptBtn.Value)
Case True: BetaSect_CheckBox.Enabled = False
BetaSect_CheckBox.Value = False
Case False: BetaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub GammaSect_OptBtn_Change()
Select Case (GammaSect_OptBtn.Value)
Case True: GammaSect_CheckBox.Enabled = False
GammaSect_CheckBox.Value = False
Case False: GammaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub DeltaSect_OptBtn_Change()
Select Case (DeltaSect_OptBtn.Value)
Case True: DeltaSect_CheckBox.Enabled = False
DeltaSect_CheckBox.Value = False
Case False: DeltaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub cmdCancel_Click()
Msg = "Are you sure you want to cancel and exit without copying?"
Ans = MsgBox(Msg, vbQuestion + vbYesNo)
Select Case Ans
Case vbYes
Me.Hide
Unload Me
Case vbNo
Exit Sub
End Select
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
' user clicked the X button
' cancel unloading the form, use close button procedure instead
Cancel = True
cmdCancel_Click
End If
End Sub
The following class:
Option Explicit
Public WithEvents aCheckBox As MSForms.CheckBox
Private Sub aCheckBox_Click()
Dim chBox As Control
Dim chBoxTag As String
chBoxTag = aCheckBox.Tag
If Right(aCheckBox.Parent.Name, 10) = "Port_Frame" Then
If aCheckBox.Value = True Then ADSinputform.Controls(chBoxTag).Enabled = True
If aCheckBox.Value = False Then
ADSinputform.Controls(chBoxTag).Enabled = False
End If
Else
If aCheckBox.Value = True Then ADSinputform.Controls(chBoxTag).Visible = True
If aCheckBox.Value = False Then
ADSinputform.Controls(chBoxTag).Visible = False
For Each chBox In ADSinputform.Controls(chBoxTag).Controls
If TypeOf chBox Is MSForms.CheckBox Then chBox.Value = False
Next
End If
End If
End Sub
I'm not sure this can be done, and I'm not real sure where to even start with it. I know I can loop through all the controls and read the state or the combobox selection, but what to do after that?
Naming:
Frames: "AlphaSect_Frame", "BetaSect_Frame", "GammaSect_Frame"
First-Level Checkboxes: "A1Checkbox", "A2Checkbox", "A3Checkbox"... "B1Checkbox", "B2Checkbox"... "C1Checkbox", "C2Checkbox"
Second-Level Checkboxes: "A1P1Checkbox", "A1P2Checkbox", "A2P1Checkbox", "A2P2Checkbox"... "B1P1Checkbox", "B1P2Checkbox", "B2P1Checkbox", "B2P2Checkbox"... "C1P1Checkbox", "C1P2Checkbox", "C2P1Checkbox", "C2P2Checkbox"
Userform Screenshots:
Here's a simple example for a form with two frames, each of which has two checkboxes:
Dim f1 As Frame, f2 As Frame, c As Control
Set f1 = Me.Frame1 'has checkboxes "f1cb1", "f1cb2"
Set f2 = Me.Frame2 'has checkboxes "f2cb1", "f2cb2"
'loop over all controls in Frame 1
For Each c In f1.Controls
If TypeName(c) = "CheckBox" Then
'set the value of the corresponding control in the other fame
Me.Controls(Replace(c.Name, "f1", "f2")).Value = c.Value
End If
Next c
I have a workbook with multiple sheets named like dates e.g 12-01-2015, 12-02-2015, .... etc. I would like to create a code that deletes specific sheets if their names are listed in an array.
I created a code but it does not work. My guess is it is related to incorrect statement listed in line starting with "If".
I would really appreciate any tip where I am going wrong
Sub DeleteSelectedSheets()
Dim i As Long
Dim Holidays() As Variant
Holidays = Array("12-3-2015", "12-4-2015")
For Each Worksheet In ActiveWorkbook
If Worksheet(i).Name = Holidays(i) Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next
End Sub
Sub DeleteSelectedSheets()
Dim Holidays As Variant
Holidays = Array("Sheet1", "Sheet3", "Sheet5")
For Each Sheet In ThisWorkbook.Sheets
If UBound(Filter(Holidays, Sheet.Name)) > -1 Then
Application.DisplayAlerts = False
Sheet.Delete
Application.DisplayAlerts = True
End If
Next
End Sub
This should work just fine!
With the exception, that will happen regardless the code you are using, where there is only one sheet left and you are trying to delete it, it'll throw an error message!
See the use of LBound() and UBound() :
Sub DeleteSelectedSheets()
Dim i As Long
Dim Holidays() As Variant
Dim wS As Worksheet
Holidays = Array("12-3-2015", "12-4-2015")
For Each wS In ActiveWorkbook
For i = LBound(Holidays) To UBound(Holidays)
If wS.Name <> Holidays(i) Then
Else
Application.DisplayAlerts = False
wS.Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
Next wS
End Sub
It may be better to simply try and delete the worksheet(s) named in the array. Of course, you will need to operate under an On Error Resume Next to guard against the condition where a worksheet named does not exist.
Sub DeleteSelectedSheets()
Dim h As Long, Holidays() As Variant
Holidays = Array("12-3-2015", "12-4-2015")
On Error Resume Next
Application.DisplayAlerts = False
For h = LBound(Holidays) To UBound(Holidays)
Worksheets(Holidays(h)).Delete
Next h
'alternate delete entire array (they need to be all there, fail on partial)
'Worksheets(Holidays).Delete
Application.DisplayAlerts = True
On Error GoTo 0
End Sub
This seems to work:
Sub DeleteSelectedSheets()
Dim i As Long
Dim Holidays() As Variant
Holidays = Array("12-3-2015", "12-4-2015")
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name = Holidays(0) Or Sheets(i).Name = Holidays(1) Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next
End Sub