I am trying to write a function that automatically deletes the minimum value for a given selection of cells. I know how to find the minimum value but I just don't know how to delete that value.
Here's what I've got.
Function MinDel(Stuff)
MinDel = Application.Worksheetfunction.min(stuff)
End Function
How do I delete the MinDel value?
You could modify the function from here like that
Option Explicit
Function AddressOfMax(rng As Range) As Range
Set AddressOfMax = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0))
End Function
Function AddressOfMin(rng As Range) As Range
Set AddressOfMin = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Min(rng), rng, 0))
End Function
Sub TestIt()
Dim rg As Range
Dim rgMin As Range
Set rg = ActiveSheet.Range("A1:A6")
Set rgMin = AddressOfMin(rg)
rgMin.Clear
End Sub
As mentioned in the comments, a UDF (User Defined Function) cannot change a value or range in Excel by default and a Sub should be used. This is my way to delete the minimal value in the Selection:
Public Sub DeleteMinimum()
Dim myRange As Range
Dim minValue As Double
Dim myMin As Range
If Not TypeOf Selection Is Excel.Range Then Exit Sub
Dim valueAssigned As Boolean: valueAssigned = False
minValue = 0
For Each myRange In Selection
If IsNumeric(myRange) Then
If Not valueAssigned Then
valueAssigned = True
minValue = myRange
Set myMin = myRange
Else
If myRange < minValue Then
minValue = myRange
Set myMin = myRange
End If
End If
End If
Next myRange
If Not myMin Is Nothing Then
myMin = "DELETED!"
End If
End Sub
The procedure below will delete the lowest value in a selection, provided that the selection comprises more than one cell. It ignores all but the first column of the selection.
Sub DelMin()
' 05 Jan 2019
Dim Arr As Variant, i As Integer
Dim Mm As Variant, m As Integer
With Selection
If .Cells.Count > 1 Then
Arr = .Value
For i = 1 To UBound(Arr)
If Not IsEmpty(Arr(i, 1)) Then
If IsEmpty(Mm) Or (Arr(i, 1) < Mm) Then
Mm = Arr(i, 1)
m = i
End If
End If
Next i
.Cells(m, 1).ClearContents
End If
End With End Sub
Related
I have a range of cells which I'm scanning if the cell has a formular or not.
When it does, I want to save the column letters and row numbers i.e. E14, E18, F18, N18 (Reference) do a dictionary.
Once I've looped through my specific range, I want to select the cells saved in the dictionary to later on delete all cells with formulas in the selected cells.
I am stuck with the part to safe the cell reference to the dictionary.
The range in the example is just an example range.
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
End Sub
You can us a collection for this purpose. You are mentioning a dictionary but for your purpose a key is not that important, you only need a list of items (collection supports both)
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
dim reflist as Collection
Set reflist = new Collection
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
refList.Add rng.Cells(i)
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
Dim oneCell as Range
foreach oneCell in refList
oneCell.Value = vbEmpty
next
End Sub
As you can see we first add the complete cell to the collectdion (it is a referenced object) and later you can use it in the foreach loop to your liking with all its properties
So I was working on resolving the issue to run the VBA faster than looping 2-3x through each column.
My current issue, which I struggle to resolve is: that the defined range "nof" or "DBRW" keeps to increase, which when resolving my final code (delete or copy formula to the Union ranges), the whole Union ranges are selected and therefore formulars are overwritten for the full range, instead of looping from column to column and using the defined formula in that column, which is available in a fixed row (Cells(6, n)).
Option Explicit
Sub Test3()
Dim i As Integer
Dim n As Integer
Dim x As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 32) As Range
Dim nof As Range
Dim nofRange(1 To 32) As Range
Dim rangef As Range
For n = 5 To 6
For i = 13 To 20
If Cells(i, n).HasFormula = True And Cells(7, n) = "A" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(7, n) = "F" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(6, n)
rangef.Copy nof
'Ranges in nof and DBRW are kept (incremented), is there a way to "refresh" the Union reference, to restart creating the range from after this step?
Next n
End Sub
´´´
so I have solved my issue and for future googlers, this might be helpful :)
Public Sub copy_paste_delete()
Dim i As Integer
Dim n As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 150) As Range
Dim nof As Range
Dim nofRange(1 To 150) As Range
Dim rangef As Range
Application.ScreenUpdating = False
Worksheets("Tab1").Activate
Range("K29").Select
Set DBRW = Nothing
Set nof = Nothing
For n = 61 To 75
Set nof = Nothing
Set DBRW = Nothing
For i = 33 To 38
If Cells(i, n).HasFormula = True And Cells(6, n) = "F" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(6, n) = "A" And Cells(7, n) = "Done" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(19, n)
On Error Resume Next
rangef.Copy nof
Next n
DBRW.Select
'Do some stuff
Application.ScreenUpdating = True
End Sub
I'm trying to perform an action in VBA on a range of cells. I would like the selection of the cells to be random not in the order of how the range is setup.
Sub Solver_Step_Evo()
Set Rng = GetRange(ThisWorkbook.ActiveSheet.Range("Variable_Range"))
For Each i In Rng
'perform an action on I where I is randomly selected.
Next i
End Sub
My preference is it randomizes the order not just randomly select a cell where a cell can be picked more than once.
Thanks in advance.
Here's a possible solution. I add all of the cells in the relevant range to a collection. Then, I navigate the collection using random indexes. Once an index has been visited, I remove it from the collection and repeat the process.
Does this work for you?
Edit: No need to call the c.Count method for each iteration. We can manage this ourselves ourselves. It would likely be a bit more efficient than calling the object's method.
Sub SuperTester()
Dim c As Collection
Dim rng As Range
Dim cel As Range
Dim idx As Long
Dim remainingCount As Long
Set rng = Range("A2:A17")
Set c = New Collection
For Each cel In rng
c.Add cel
Next cel
remainingCount = c.Count
While remainingCount > 0
idx = WorksheetFunction.RandBetween(1, c.Count)
Debug.Print c.Item(idx).Address
c.Remove idx
remainingCount = remainingCount - 1
Wend
End Sub
You can use WorksheetFunction.RandBetween to get random number between 2 numbers. The numbers will not be unique though. If you want unique then you will have to use a slightly different approach.
Option Explicit
Sub Solver_Step_Evo()
Dim Rng As Range
Set Rng = GetRange(ThisWorkbook.ActiveSheet.Range("Variable_Range"))
Dim lowerBound As Long: lowerBound = 1
Dim UpperBound As Long: UpperBound = Rng.Cells.Count
Dim randomI As Long
Dim i As Long
For i = lowerBound To UpperBound
randomI = Application.WorksheetFunction.RandBetween(lowerBound, UpperBound)
Debug.Print randomI
Next i
End Sub
Try the next function, please:
Function RndCell(rng As Range) As Range
Dim rndRow As Long, rndCol As Long
rndRow = WorksheetFunction.RandBetween(1, rng.rows.count)
rndCol = WorksheetFunction.RandBetween(1, rng.Columns.count)
Set RndCell = rng.cells(rndRow, rndCol)
End Function
It can be tested using the next simple sub:
Sub testSelectRandomCell()
Dim rng As Range
Set rng = Range("A2:D10")
RndCell(rng).Select
End Sub
Edited:
If the random selected cells should not repeat, the function can be adapted in the next way (using a Static array to keep the already selected cells):
Function RndCellOnce(rng As Range, Optional boolClear As Boolean = False) As Range
Dim rndRow As Long, rndCol As Long, k As Long, El, arr1
Static arr
If boolClear And IsArray(arr) Then Erase arr
DoItAgain:
rndRow = WorksheetFunction.RandBetween(1, rng.rows.count)
rndCol = WorksheetFunction.RandBetween(1, rng.Columns.count)
If IsArray(arr) Then
If UBound(arr) = rng.cells.count - 1 Then
rng.Interior.Color = xlNone
ReDim arr(0): GoTo Over
End If
For Each El In arr
If El <> "" Then
arr1 = Split(El, "|")
If CLng(arr1(0)) = rndRow And CLng(arr1(1)) = rndCol Then GoTo DoItAgain
End If
Next El
ReDim Preserve arr(UBound(arr) + 1)
Else
ReDim arr(0)
End If
Over:
arr(UBound(arr)) = rndRow & "|" & rndCol
Set RndCellOnce = rng.cells(rndRow, rndCol)
End Function
It can be tested with the next Sub. In order to visually check it, each selected cell will get a yellow interior color. When all the range cells will be selected (one by one), the static array will be erased and the interior color will be cleaned:
Sub testSelectRandomCell()
Dim rng As Range
Set rng = Range("A2:D10")
With RndCellOnce(rng)
.Interior.Color = vbYellow
.Select
End With
End Sub
I want to create a button that, when the user presses it, will do this:
before press the button user mark name in pivot table on sheet Eff
after press button the same name will be filter in another pivot table on sheet Pivot_All
I tried this, but in .PivotItems(a(g)).Visible = True it gives me object required error
Public Function GetLength(a As Variant) As Integer
If IsEmpty(a) Then
GetLength = 0
Else
GetLength = UBound(a) - LBound(a) + 1
End If
GL = GetLength
End Function
Public Function a(ByVal rng As Range) As Variant
Dim f As Long, r As Range
ReDim arr(1 To rng.Count)
f = 1
For Each r In rng.Cells
arr(f) = r.Value
f = f + 1
Next r
a = arr
End Function
Sub Macro6()
Dim rngCopy As Range
Dim rngPaste As Range
Dim rng As Range
Set rng = Selection
Sheets("Pivot_All").Activate
ActiveSheet.PivotTables("PivotTable1").PivotFields("Empl").ClearAllFilters
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Empl")
For i = 1 To .PivotItems.Count - 1
.PivotItems(.PivotItems(i).Name).Visible = False
Next i
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Empl")
For g = 0 To GL
.PivotItems(a(g)).Visible = True
Next g
End With
End Sub
a is waiting for a range a(ByVal rng As Range) but you submit a number g as parameter. You must submit a Range object instead.
Also GL is not defined in your procedure, I assume you wanted to use GetLength instead.
So it should be something like:
Dim ResultOfA As Variant
ResultOfA = a(Range("your range here"))
For g = 0 To GetLength(ResultOfA)
.PivotItems(ResultOfA(g)).Visible = True
Next g
I recommend always to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration.
Note that you can read a continous range into an array in one line:
Dim ArrValues() As Variant
ArrValues = Range("A1:A10").Value
Debug.Print ArrValues(1, 5) '= A5
If you use this you might not need your function a anymore.
You would end up with something like:
Option Explicit
Public Sub Macro6()
Dim rngCopy As Range
Dim rngPaste As Range
Dim rng As Range
Set rng = Selection
Dim ws As Worksheet
Set ws = Worksheets("Pivot_All")
With ws.PivotTables("PivotTable1").PivotFields("Empl")
.ClearAllFilters
Dim i As Long
For i = 1 To .PivotItems.Count - 1
.PivotItems(.PivotItems(i).Name).Visible = False
Next i
Dim ResultOfA As Variant
ResultOfA = a(rng)
If Not IsEmpty(ResultOfA) Then
Dim g As Long
For g = LBound(ResultOfA) To UBound(ResultOfA)
.PivotItems(ResultOfA(g)).Visible = True
Next g
End If
End With
End Sub
Public Function a(ByVal rng As Range) As Variant
Dim f As Long, r As Range
ReDim arr(1 To rng.Count)
f = 1
For Each r In rng.Cells
arr(f) = r.Value
f = f + 1
Next r
a = arr
End Function
In my Sheet 1, Column A has some values and I need to create a Active X checkbox for all the values in Sheet 2 in a specific cell. First I need to check whether Active X checkbox is there for the value or not, If its not there, I need to create. I already tried the below code, But its creating the duplicate checkboxes.
Sub Addcheckbox()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=183, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
rr = rr + 1
Next cell
End Sub
How to check whether ActiveX checkbox already present in the sheet or not with Caption name
i tried this code for checking the checkboxes.. But its not working..
Function shapeExists(ByRef shapename As String) As Boolean
shapeExists = False
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.name = shapename Then
shapeExists = True
Exit Function
End If
Next sh
End Function
ActiveX Checkboxes are OleObjects. Is this what you are trying?
Also you need to specify the correct .Top else they will be created at the same place. See how I used Top:=cell.Top
Sub Sample()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
If Not CBExists(cell.Value) Then '<~~ Check if the checkbox exists
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=cell.Top, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
End If
rr = rr + 1
Next cell
End Sub
'~~> Function to check if the checkbox exists
Function CBExists(s As String) As Boolean
Dim oleObj As OLEObject
Dim i As Long
For i = 1 To Worksheets("Sheet1").OLEObjects.Count
If s = Worksheets("Sheet1").OLEObjects(i).Object.Caption Then
CBExists = True
Exit Function
End If
Next i
End Function
32 Bit Excel 365 on 64 Bit Win7
Worksheet 300600 Rows x 105 Columns
Goal: Calculate the Number of Unique Entries in each Column
Attempted Solution 1: Formula
{=SUM(1/COUNTIF(A8:A300600,A8:A300600))}
Issue: Long Runtime, Freezes Excel, Must Stop Calculation
Attempted Solution 2: VBA UDF
Function UniqueCount(Selection As Range) As Integer
Dim UniqueArray()
ReDim UniqueArray(0 To Selection.Count)
Dim Rng As Range
Dim CUniqueCount As Integer
CUniqueCount = 0
For Each Rng In Selection
For i = 0 To Selection.Count
If UniqueArray(i) = Rng.Value Then Exit For
If UniqueArray(i) = "" Then
UniqueArray(i) = Rng.Value
CUniqueCount = CUniqueCount + 1
Exit For
End If
Next i
Next
UniqueCount = CUniqueCount
End Function
Note: This is Much faster, but I'm still looking for an even faster approach
I'd use an array as well as the Dictionary:
Public Function CountUnique(rngInput As Range) As Double
Dim rngCell As Range
Dim dData As Object
Dim vData
Dim x As Long
Dim y As Long
Set dData = CreateObject("Scripting.Dictionary")
vData = rngInput.Value2
For x = LBound(vData, 1) To UBound(vData, 1)
For y = LBound(vData, 2) To UBound(vData, 2)
If LenB(vData(x, y)) <> 0 Then dData(CStr(vData(x, y))) = Empty
Next y
Next x
CountUnique = dData.Count
End Function
Try this
'Set a reference to MS Scripting runtime ('Microsoft Scripting Runtime')
Function UniqueCount(SelRange As Range)
Dim Rng As Range
Dim dict As New Scripting.Dictionary
Set dict = CreateObject("Scripting.Dictionary")
For Each Rng In SelRange
If Not dict.Exists(Rng.Value) Then
dict.Add Rng.Value, 0
End If
Next Rng
UniqueCount = dict.Count
Set dict = Nothing
End Function