Is there away to have cell value add or delete copies of either cell ranges or worksheets without use of a button - excel

I'm trying to make a cell value dictate how many copies should be made. I'm trying to make it if the cell value goes down that it will delete the sheets that are higher than the value. I currently have the adding working no problem just can't figure out how to make it delete copies when the value gets smaller. I figure I could make a button do a check just trying to make it more automated.
Sub CreateDistro()
Dim i As Long
Dim Num As Integer
Dim Name As String
Dim xActiveSheet As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Set ActiveSheet = ActiveSheet
Num = Range("C1")
If Num > 1 Then
For i = 1 To Num
Name = ActiveSheet.Name
xActiveSheet.Copy After:=ActiveWorkbook.Sheets(Name)
ActiveSheet.Name = "Distro-" & i
Next
End If
xActiveSheet.Activate
Application.ScreenUpdating = True
End Sub

Problem of the code below: it reacts on the Range("C1") of all sheets!
You might want to use a named range or limit the number of possible sheets(e.g. minimum number of sheets = 2, template to be copied is sheet 2,only sheet1 has the Worksheet_Change code.
Sheet1:
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Call ChangeSheets(target)
End Sub
Module1:
Option Explicit
Sub ChangeSheets(ByVal target As Range)
Dim iCt As Integer
Dim Num As Integer
Dim maxSh As Integer
'If Not Intersect(Target, Range("C1")) Is Nothing Then
' MsgBox ("C1: " & Target.Value)
'End If
If target.Value <= 0 Then
MsgBox "Minimum worksheet count = 1!" & vbCrLf & "Nothing to do!"
Application.EnableEvents = False
target.Value = 1
Application.EnableEvents = True
Application.DisplayAlerts = False
maxSh = Sheets.Count
For iCt = maxSh To 2 Step -1
Sheets(iCt).Delete
Next iCt
Application.DisplayAlerts = True
Exit Sub
End If
If Worksheets.Count = target.Value Then
MsgBox "Worksheet count = " & target.Value & vbCrLf & "Nothing to do!"
Exit Sub
End If
'add some sheets
If Worksheets.Count < target.Value Then
Num = target.Value - Worksheets.Count
For iCt = 1 To Num
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Next iCt
Exit Sub
End If
'delete some sheets
If Worksheets.Count > target.Value Then
Num = Worksheets.Count - target.Value
Application.DisplayAlerts = False
maxSh = Sheets.Count
For iCt = 0 To Num - 1
Debug.Print maxSh - iCt; ": "; Sheets(maxSh - iCt).Name
Sheets(maxSh - iCt).Delete
Next iCt
Application.DisplayAlerts = True
Exit Sub
End If
End Sub

Related

How to populate a cell in a different sheet based on the value in another sheet and vice versa

I am trying to use VBA so that I can input a value in cell B7 in sheet2 and then it would automatically populate in C7 in sheet3 and also work vice versa. I tried the code below and couldn't get it to work, any suggestions? Also would the code be the same for a string of a number?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo eh
If Not Intersect(Target, ThisWorkbook.Sheets("sheet 2").Range("B7")) Is Nothing Then
Application.EnableEvents = False
ThisWorkbook.Sheets("sheet 3").Range("C" & Target.Row - 0).Value = Target.Value
eh:
Application.EnableEvents = True
If Err <> 0 Then MsgBox Err & " " & Err.Description, , "Error in Worksheet_Change event, sheet 2"
End If
End Sub
A Workbook SheetChange: Same Value in Cells of Worksheets
Note that the code needs to be copied to the ThisWorkbook module.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsNames As Variant: wsNames = VBA.Array("sheet 2", "sheet 3")
Dim CellAddresses As Variant: CellAddresses = VBA.Array("B7", "C7")
Dim iCell As Range
Dim n As Long
For n = 0 To UBound(wsNames)
If StrComp(Sh.Name, wsNames(n), vbTextCompare) = 0 Then
Set iCell = Intersect(Sh.Range(CellAddresses(n)), Target)
If Not iCell Is Nothing Then
Application.EnableEvents = False
Me.Worksheets(wsNames(1 - n Mod 2)) _
.Range(CellAddresses(1 - n Mod 2)).Value = iCell.Value
Application.EnableEvents = True
End If
Exit For
End If
Next n
End Sub

Memory leak when opening Excel - resulting in a crash

I have a matrix with i.e dimensions 300x300 (x & y,size vary from project to project).
The names/numbers of the individual rows are transposed to the columns.
The matrix is divided diagonally, and I use it to tag relations between different "systems".
The tag have to be a unique number. See image:
I do not want duplicated relations, so I just want to use the white cells to add the tag.
(The black ones are there to show that the system cant have a relation with itself.)
I have tried to make a range, that I apply a Validation to later which shows me the next number in line for the tag:
Public MatrixRange as Range
Private Sub Worksheet_Activate()
Dim n As Integer
Dim NextRange As Range
Dim OldRange As Range
Dim LastRow As Long
With shMatrix
LastRow = .Range("A" & .Rows.Count).End(xlUp).row
Set MatrixRange = .Range("C11")
If LastRow <= 1 Then Exit Sub
For n = 2 To .Range(.Range("A9").Offset(1, 0).Address, "A" & LastRow).Rows.Count
Set OldRange = MatrixRange
Set NextRange = .Range(.Range("B9").Offset(n, 1), .Range("B9").Offset(n, -1 + n))
Set MatrixRange = Union(OldRange, NextRange)
Next n
End With
End Sub
This code give me the correct range that I want, but it sometimes hogs a whole lot of memory when I open the workbook or try to save. The RAM just goes up and up when I start it, before the workbook just crashes without any error message.
Rewriting the code to select the whole matrix, not just the one half, seems to fix the issue.
My question is this: is it possible to rewrite the code so I get the correct range, with a different method or are there any flaws in my code that will create a memory leak?
I call the above sub also when applying the Validation, if MatrixRange is not created:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ValMax As Integer
If MatrixRange Is Nothing Then
Call CreateMatrixRange
End If
ValMax = Application.WorksheetFunction.Max(MatrixRange)
With MatrixRange.Validation
.Delete
.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
Operator:=xlEqual, Formula1:=ValMax + 1
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = "Next number"
.ErrorTitle = "Error"
.InputMessage = ValMax + 1
.ErrorMessage = "Next number is: " & ValMax + 1
.ShowInput = True
.ShowError = True
End With
End Sub
Thank you for your answers!
Try the following:
Option Explicit
Private prMatrix As Range
'* plLastRow is used to check if the matrix range changes after it had been set
Private plLastRow As Long
Private Function GetMatrixRange() As Range
Dim lStartCol As Long: lStartCol = 3
Dim lStartRow As Long: lStartRow = 11
Dim lLastRow As Long
Dim i As Long
With shMatrix
lLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lLastRow < lStartRow Then lLastRow = lStartRow
If prMatrix Is Nothing Or lLastRow <> plLastRow Then
plLastRow = lLastRow
Set prMatrix = .Cells(lStartRow, lStartCol)
'* Row Number -> Number of Columns mapping
'* Row 11 -> 1 column
'* Row 12 -> 2 columns
'* Row 13 -> 3 columns , ...etc
'* Therefore, Number Of Columns = Row Number - lStartRow + 1
For i = lStartRow + 1 To lLastRow
Set prMatrix = Union(prMatrix, .Cells(i, lStartCol).Resize(1, i - lStartRow + 1))
Next i
End If
End With
Set GetMatrixRange = prMatrix
End Function
Private Function GetNextValue() As Long
GetNextValue = WorksheetFunction.Max(GetMatrixRange) + 1
End Function
'Private Sub SetValidation()
' Dim lNextValue As Long
' lNextValue = GetNextValue
'
' With GetMatrixRange.Validation
' .Delete
' .Add Type:=xlValidateWholeNumber, _
' AlertStyle:=xlValidAlertStop, _
' Operator:=xlEqual, _
' Formula1:=lNextValue
' .IgnoreBlank = True
' .InCellDropdown = False
' .InputTitle = "Next number"
' .ErrorTitle = "Error"
' .InputMessage = lNextValue
' .ErrorMessage = "Next number is: " & lNextValue
' .ShowInput = True
' .ShowError = True
' End With
'End Sub
'
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' SetValidation
'End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo ErrorHandler
Application.EnableEvents = False
If Not Intersect(Target, GetMatrixRange) Is Nothing Then
If Target = Empty Then Target.Value = GetNextValue
Cancel = True
End If
ErrorHandler:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler
Application.EnableEvents = False
Dim rWatched As Range: Set rWatched = Intersect(Target, GetMatrixRange)
Dim lNextValue As Long
Dim lEnteredValue As Long
If Not rWatched Is Nothing Then
Target.Select
If rWatched.Cells.Count > 1 Then
rWatched.ClearContents
MsgBox "You cannot change more than 1 matrix cell at a time"
ElseIf Not IsNumeric(rWatched.Value) Then
rWatched.ClearContents
MsgBox "Only numeric values allowed"
Else
If rWatched.Value <> Empty Then
lEnteredValue = rWatched.Value
rWatched.ClearContents
lNextValue = GetNextValue
If lEnteredValue <> lNextValue Then
If MsgBox("The next allowed value is: " & lNextValue & ". Do you want to accept it?", vbYesNo) = vbYes Then
rWatched.Value = lNextValue
End If
Else
rWatched.Value = lEnteredValue
End If
End If
End If
End If
ErrorHandler:
Application.EnableEvents = True
End Sub
I replaced the validation code with double-click and change event handlers. Feel free to remove these handlers and uncomment the validation and selection change code if you need to.
This code will do the following:
If you change any cell in the matrix, it will validate it and give
you the choice to accept the allowed value. Otherwise, it will delete
what you had entered.
If you double-click a cell in the matrix, it will be populated with the next value

Invalid use of property in VBA

I've been following a tutorial on Youtube for an employee manager, It uses a lot of features that i don't need so I've been trying to pick out parts that it need.
I have no experience with VBA or coding so I'm struggling to work out why certain things wont work.
The Screenshots have annotations of the intended results.
Than you in advance
Example and annotations of intended result
Error message
Debug view
Here are my Macros for the buttons and the refresh
Option Explicit
Public EventRow As Long
Public EventCol As Long
Public MapRng As String
Sub Event_SaveNew()
With Sheet6
'check req fields
If Sheet3.Range("g3").Value = Empty Or Sheet3.Range("g5").Value = Empty Then
MsgBox ("Event Name and Event Type are required fields for ANY Event")
Exit Sub
End If
EventRow = .Range("E2000").End(xlUp).Row + 1 'first av row
.Cells(EventRow, 5).Value = Sheet3.Range("b7").Value 'new event id
For EventCol = 6 To 12
.Cells(EventRow, EventCol).Value = Sheet3.Range(.Cells(1, EventCol).Value).Value 'event feild
Next EventCol
End With
With Sheet3
.Range("B2").Value = False 'set new event to false
.Range("B4").Value = Sheet6.Cells(EventRow, 1).Value 'New event ID
Event_Refresh
'reload events
End With
End Sub
Sub Event_Refresh()
Dim LastEventRow As Long
Dim LastFiltRow As Long
With Sheet3
'load Events list into events sheet using adv filter and sort
.Range("f22:m2000").ClearContents 'clear existing events list
LastEventRow = Sheet6.Range("e2000").End(xlUp).Row + 6
Sheet6.Range ("e4:L" & LastEventRow)
End With
End Sub
Sub Event_AddNew()
With Sheet3
.Range("B1").Value = True 'set event load to true
.Range("b2").Value = True 'set new event to true
.Range("J7,j5,g5,g3,f11:j17,g7,g8,j3").ClearContents
.Range("b1").Value = False 'set event load to false
.Range("G3").Select
End With
End Sub
Sub Event_Load()
Dim SelRow As Long
With Sheet3
SelRow = .Range("b9").Value
If .Range("B3").Value = Empty Then
MsgBox "Please select on an Event to display Event details"
Exit Sub
End If
.Range("b1").Value = True 'set empload to true
EventRow = .Range("b3").Value
End With
With Sheet6
For EventCol = 6 To 12
MapRng = Sheet6.Cells(1, EventCol).Value
.Range(MapRng).Value = Sheet6.Cells(EventRow, EventCol).Value 'add maped values
Next EventCol
End With
With Sheet3
.Range("B2").Value = False 'set new event to false
.Range("B1").Value = False 'set event load to false
End With
End Sub
Sub Event_Delete()
If MsgBox("Are you sure you want to DELETE this event?", vbYesNo, "Delete Event") = vbNo Then Exit Sub
With Sheet3
If .Range("B3").Value = Empty Then Exit Sub
EventRow = .Range("B3").Value 'event row
Sheet6.Range(EventRow & ":" & EventRow).EntireRow.Delete
Event_Refresh 'refresh events
End With
End Sub
Sub Event_CancelNew()
With Sheet3
.Range("b2").Value = False
Sheet3.Range("F22").Select
End With
End Sub
And here is the code for the Event log page
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MapRng As Range
Dim FoundMapRng As Range
Dim CellAdd As String
Dim SellRow As Long
'exsisting event change update event tab
If Not Intersect(Target, Range("F3:L17")) Is Nothing And Range("B2").Value = False And Range("B1").Value = False And IsNumeric(Cells(Target.Row, Target.Column + 25).Value) = True And Cells(Target.Row, Target.Column + 25).Value <> Empty Then
Sheet6.Cells(Range("b3").Value, Cells(Target.Row, Target.Column + 25).Value).Value = Target.Value
End If
'update below
CellAdd = Target.Address
SellRow = Range("b9").Value
Set MapRng = Sheet3.Range("EventDataMap")
Set FoundMapRng = MapRng.Find(CellAdd, , xlValues, xlWhole)
If Not FoundMapRng Is Nothing Then Cells(SellRow, FoundMapRng.Column).Value = Sheet6.Cells(Range("b3").Value, Cells(Target.Row, Target.Column + 25).Value).Value
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
'on table selection
If Not Intersect(Target, Range("F22:M2000")) Is Nothing And Range("f" & Target.Row).Value <> Empty Then
Range("b9").Value = Target.Row 'add in selection row
Range("b4").Value = Range("f" & Target.Row).Value 'add event ID
Event_Load
End If
End Sub

Excel VBA Resize Table Copying Formulas & Shapes

I have a table containing formulas and shapes on every row.
I want to resize the table based on a user's input from userform (Lets just call the value given TextBox1.Value) The user inputs a new desired table row size into the userform and clicks "OK"
Let's call the Table Table1, see code below:
Private Sub UserForm_Initialize()
Dim ob As ListObject
Dim count As Integer
Set ob = Sheets("Worksheet").ListObjects("Table1")
count = ob.Range.Rows.count - 1
TextBox1.value = count
End Sub
Private Sub OKButton_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim ob As ListObject
Dim count As Integer, i As Integer, j As Integer
Set ob = Sheets("Worksheet").ListObjects("Table1")
count = ob.Range.Rows.count - 1
If TextBox1.value < 2 Then
Unload Me
ElseIf TextBox1.value > count Then
ob.Resize ob.Range.Resize(TextBox1.value + 1)
ob.ListRows(count).Range.Select
Selection.AutoFill Destination:=ob.ListRows(count & ":" &_
TextBox1.value).Range,Type:=xlFillDefault
ob.ListRows(TextBox1).Range.Select
ElseIf TextBox1.value < count Then
ob.Range.Rows(TextBox1.value + 1 & ":" & count).Delete
End If
Application.CutCopyMode = False
Unload Me
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
My issue is when the user inputs a value greater than the table's current row count.
The table resizes correctly, but there is an error when copying the rows.
"Run Time Error 9, Subscript out of Range"
The desire is to copy down the formulas and shapes to the newly created rows quickly.
Can anyone see what I'm doing wrong?
You can't reference multiple ListRows like ListRows(1:2) like you can with worksheet rows. That property doesn't support that argument syntax. Change that ElseIf to
ElseIf TextBox1.Value > count Then
ob.Resize ob.Range.Resize(TextBox1.Value + 1)
ob.ListRows(count).Range.Resize(Me.TextBox1.Value - count + 1).FillDown
and you will avoid that error.
Here is the result working correctly for anyone who may have use for it:
Private Sub UserForm_Initialize()
Dim ob As ListObject
Dim count As Integer, i As Integer, j As Integer
Set ob = Sheets("Worksheet").ListObjects("Table1")
count = ob.Range.Rows.count - 1
TextBox1.value = count
End Sub
Private Sub OKButton_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim ob As ListObject
Dim count As Integer, i As Integer, j As Integer, k As Integer, m As Integer
Set ob = Sheets("Worksheet").ListObjects("Table1")
count = ob.Range.Rows.count - 1
If TextBox1.value < 2 Then
Unload Me
ElseIf TextBox1.value > count Then
ob.Resize ob.Range.Resize(TextBox1.value + 1)
ob.ListRows(count).Range.Resize(Me.TextBox1.value - count + 1).FillDown
ElseIf TextBox1.value < count Then
Debug.Print "TextBox1:" & TextBox1.value & " count:" & count
ob.Range.Rows(TextBox1.value + 2 & ":" & count + 1).Delete
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.UsedRange
Unload Me
End Sub

Update excel cell with date if a cell in a range is update

I need to update a cell with the date and time stamp (NOW()) if any cell is updated within any cell before it within that same row.
So update cell "CU" with date and time when any cell from "A-CR" is updated.
I have done some searching but I can only seem to find bits that work if only updating a single cell, I'm looking for if anything changes within that range.
I currently have some Vba which does something similar which will update the adjacent cell with time and date which is required but I also need an overall one for the whole process.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F:F, I:I, L:L, O:O, R:R, U:U, X:X, AA:AA, AB:AB, AE:AE, AH:AH, AK:AK, AN:AN, AQ:AQ, AT:AT, AW:AW, AZ:AZ, BC:BC, BF:BF, BI:BI, BL:BL, BO:BO, BR:BR, BU:BU, BX:BX, CA:CA, CD:CD, CG:CG, CJ:CJ, CM:CM, CP:CP")) Is Nothing Then
On Error GoTo safe_exit
With Application
.EnableEvents = False
.ScreenUpdating = False
Dim trgt As Range, ws1 As Worksheet
'Set ws1 = ThisWorkbook.Worksheets("Info")
For Each trgt In Intersect(Target, Range("F:F, I:I, L:L, O:O, R:R, U:U, X:X, AA:AA, AB:AB, AE:AE, AH:AH, AK:AK, AN:AN, AQ:AQ, AT:AT, AW:AW, AZ:AZ, BC:BC, BF:BF, BI:BI, BL:BL, BO:BO, BR:BR, BU:BU, BX:BX, CA:CA, CD:CD, CG:CG, CJ:CJ, CM:CM, CP:CP"))
If trgt <> vbNullString Then
If UCase(trgt.Value) = "Y" Or UCase(trgt.Value) = "N" Then
Cells(trgt.Row, trgt.Column + 1) = Now()
Cells(trgt.Row, trgt.Column + 2) = Environ("username")
'Select Case trgt.Column
' Case 2 'column B
' Cells(trgt.Row, trgt.Column + 1) = Environ("username")
' Case 4 'column D
' 'do something else
' End Select
Else
trgt = ""
Cells(trgt.Row, trgt.Column + 1) = ""
Cells(trgt.Row, trgt.Column + 2) = ""
End If
End If
Next trgt
'Set ws1 = Nothing
End With
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
This works for me:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Intersect(Target, Me.Range("A" & Target.Row & ":CR" & Target.Row)) Is Nothing Then GoTo SafeExit
Me.Cells(Target.Row, "CU") = Now()
SafeExit:
Application.EnableEvents = True
End Sub
The below code takes care of:
Clearing the time if the row is blank.
Updating the time only if the values really change from the previous value.
Dim oldValue As String
'Change the range below where your data will be
Const RangeString = "A:CR"
'Below variable decides the column in which date will be displayed
'Change the below value to 1 for column A, 2 for B, ... 99 for CU
Const ColumnIndex = 99
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim HorizontalRng As Range
Dim Rng As Range
Dim HorRng As Range
Dim RowHasVal As Boolean
Set WorkRng = Intersect(ActiveSheet.Range(RangeString), Target)
If Not WorkRng Is Nothing Then
If WorkRng.Cells.Count = 1 And WorkRng.Cells(1, 1).Value = oldValue Then
Exit Sub
End If
Application.EnableEvents = False
For Each Rng In WorkRng
Set HorizontalRng = Intersect(ActiveSheet.Range(RangeString), Rows(Rng.Row))
RowHasVal = False
For Each HorRng In HorizontalRng
If Not VBA.IsEmpty(HorRng.Value) Then
RowHasVal = True
Exit For
End If
Next
If Not RowHasVal Then
ActiveSheet.Cells(Rng.Row, ColumnIndex).ClearContents
ElseIf Not VBA.IsEmpty(Rng.Value) Then
ActiveSheet.Cells(Rng.Row, ColumnIndex).Value = Now
ActiveSheet.Cells(Rng.Row, ColumnIndex).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End If
Next
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, ActiveSheet.Range(RangeString)) Is Nothing Then
If Target.Cells.Count = 1 Then
oldValue = Target.Value
Else
oldValue = ""
End If
End If
End Sub

Resources