There is user-defined function (UDF), which is located on all worksheets of the workbook.
How can I refer to the worksheet in which the function is located?
I am using ThisWorkbook.ActiveSheet, but the results are constantly changing.
Function äëÿñèò(Diapozon As Range) As Long
'äëÿ ñèòóàöèè
Application.Volatile
Dim n As Long
Dim C As Range
Dim m As Long
m = -1
n = 0
For Each C In Diapozon.Rows
If C.Value = 1 Then
m = m + 1
If ThisWorkbook.ActiveSheet.Cells(101, 42 + (m * 21)).Value = 1 Then
n = n + 1
End If
End If
Next C
äëÿñèò = n
End Function
You can use Application.Caller to refer to the cell which is calling the function, therefore you can use Application.Caller.Worksheet to refer to that cell's worksheet.
Related
I am trying to write a function that loops through column values and applies numbers 1,2,3...n in between cells with strings. for example:
data:
hefew
1
3
2
6
bkifew
3
4
2
1
3
I want the function to change the values to:
hefew
1
1
1
1
bkifew
2
2
2
2
2
There could be multiple strings, so the end value could end up being 15 or so.
I have started a basic function but I am not familiar enough with VBA to work the logic. I program in Python and would normally do stuff like this in that language. However, I'm forced to keep this within excel.
current working:
Sub Button2_Click()
Dim rng As Range, cell As Range
cellcount = CountA("A1:A1000")
Set rng = Range("A1:A10")
For Each cell In rng
a = cell.Value
If IsNumeric(a) = True Then
cell.Value = 1
Else
cell.Value = 0
End If
Next cell
End Sub
I don't think this is possible with a for loop. Is there some sort of search and replace function that I could use?
Try this, assuming the numbers are not the result of formulae.
Sub x()
Dim r As Range, n As Long
For Each r In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
n = n + 1
r.Value = n
Next r
End Sub
I created a function instead of sub which is little bit messy but it works. Tested at my pc
Public Function Test(checkrange As Range, checkcell As Range)
Dim cll As Range
Dim arr() As Variant
ReDim Preserve arr(1 To checkrange.Cells.Count)
If IsNumeric(checkcell.Value) = False Then
Test = checkcell.Value
Exit Function
End If
y = 1
For Each cll In checkrange
If IsNumeric(cll.Value) Then
arr(y) = 1
Else
arr(y) = 0
End If
y = y + 1
Next cll
m = 1
For Each cll In checkrange
If cll.Address = checkcell.Address Then
rownumber = m
Exit For
End If
m = m + 1
Next cll
m = 0
For i = LBound(arr) To UBound(arr)
If arr(i) = 0 Then
m = m + 1
End If
If i = rownumber Then Exit For
Next i
Test = m
End Function
I do some macro and i upgrade a macro of Diedrich to have a MaxIfs in excel 2010 which work with line an columns i put the code under.
Public Function maxifs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant
Application.Volatile
Dim n As Long
Dim i, j As Long
Dim c As Variant
Dim f As Boolean
Dim w() As Long
Dim k As Long
Dim z As Variant
'Error if less than 1 criteria
On Error GoTo ErrHandler
n = UBound(Criteria)
If n < 1 Then
'too few criteria
GoTo ErrHandler
End If
'Define k
k = 0
'Loop through cells of max range
For i = 1 To MaxRange.Count
For j = 1 To MaxRange.Count
'Start by assuming there is a match
f = True
'Loop through conditions
For c = 0 To n - 1 Step 2
'Does cell in criteria range match condition?
If Criteria(c).Cells(i, j).Value <> Criteria(c + 1) Then
f = False
End If
Next c
'Define z
z = MaxRange
'Were all criteria satisfied?
If f = True Then
k = k + 1
ReDim Preserve w(k)
w(k) = z(i, j)
End If
Next j
Next i
maxifs = Application.Max(w)
Exit Function
ErrHandler:
maxifs = CVErr(xlErrValue)
End Function
So now i will do the minifs and it does not work if all my value are positives.
How can i do?
ps: if you change in this macro max by median it will work too
Thanks for your answers.
It is because you are starting the array w with an empty slot at 0, since the first slot you fill is slot 1.
So w(0) is 0, Which when all the others are positive it is the minimum number.
So change K=-1 instead of K=0 When initially assigning value to k.
I also moved z in front of the loop, there is no reason to keep assigning that array. It only needs to be assigned once.
Also, I changed the ranges a little to only look at the used range, this way you can use full column references.
Also, the loops need to be through the rows and columns not two loops through the whole range as it causes many unnecessary loops.
Public Function minifs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant
Application.Volatile
Dim n As Long
Dim i, j As Long
Dim c As Variant
Dim f As Boolean
Dim w() As Long
Dim k As Long
Dim z As Variant
'Error if less than 1 criteria
On Error GoTo ErrHandler
n = UBound(Criteria)
If n < 1 Then
'too few criteria
GoTo ErrHandler
End If
'Define z
z = Intersect(MaxRange, MaxRange.Parent.UsedRange).Value
'Define k
k = -1
'Loop through cells of max range
For i = 1 To UBound(z, 1)
For j = 1 To UBound(z, 2)
'Start by assuming there is a match
f = True
'Loop through conditions
For c = 0 To n - 1 Step 2
'Does cell in criteria range match condition?
If Intersect(Criteria(c), Criteria(c).Parent.UsedRange).Cells(i, j).Value <> Criteria(c + 1) Then
f = False
End If
Next c
'Were all criteria satisfied?
If f = True Then
k = k + 1
ReDim Preserve w(k)
w(k) = z(i, j)
End If
Next j
Next i
minifs = Application.Min(w)
Exit Function
ErrHandler:
minifs = CVErr(xlErrValue)
End Function
Also a note as this will only do = in the criteria and not any other function like >,<,<>,....
I found this piece of code that searches through the H column in a sheet and copies the cells which contain the word "apply" in a new workbook.
I then tried to change it so it would copy the entire row, but can't figure out what I'm doing wrong, as it now just opens a new workbook and leaves it empty.
Can someone look at the code and tell me what I'm doing wrong?
Many thanks
Sub test()
Dim K, X As Long, r As Range, v As Variant
K = 1
X = 5
Dim w1 As Workbook, w2 As Workbook
Set w1 = ThisWorkbook
Set w2 = Workbooks.Add
w1.Activate
For Each r In Intersect(Range("H:H"), ActiveSheet.UsedRange)
v = r.Value
X = X + 1
If InStr(v, "applied") > 0 Then
'**Initial line** - r.Copy w2.Sheets("Sheet1").Cells(K, 1)
With w2
w1.Sheets("Sheet1").Rows("X:X").Copy .Sheets("Sheet1").Rows("K")
K = K + 1
End With
End If
Next r
End Sub
There are multiple errors in your code.
You are using strings for row references. "X:X" will resolve to the string X:X. It will not substitute the value of X inside the string. Same for "K" on sheet 2.
you are copying the row five below the row in which you find "applied".
If you want to copy the same row, I would suggest:
Dim K, X As Long, r As Range, v As Variant
K = 1
Dim w1 As Workbook, w2 As Workbook
Set w1 = ThisWorkbook
Set w2 = Workbooks.Add
w1.Activate
For Each r In Intersect(Range("H:H"), ActiveSheet.UsedRange)
v = r.Value
X = X + 1
If InStr(v, "applied") > 0 Then
r.EntireRow.Copy w2.Sheets("Sheet1").Rows(K)
K = K + 1
End If
Next r
You could also change the Copy line to:
r.EntireRow.Copy w2.Sheets("Sheet1").Cells(K, 1)
but I don't know if the one is more efficient than the other.
I'm trying to write a Macro which will delete every row, apart from those which contain some specific text.
I need to have the following criteria:
Never delete the first 2 rows
Exclude the rows where the word "Somme" can be found in column C or D.
Note, the word Somme if part of a string in column C or D. An example of the text found would be something like:
Somme alpha/000284727819293
What I have so far is code which deletes rows with Somme in it, however i need the opposite:
Sub CleanUp()
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("D3", ActiveSheet.Range("D65536").End(xlUp))
Do
Set c = SrchRng.Find("Somme", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
End Sub
Give this a shot:
Sub SaveSomeRows()
Dim N As Long, L As Long, r As Range
Dim s As String, v As String
Set r = ActiveSheet.Range("D3", ActiveSheet.Range("D65536").End(xlUp))
N = r.Count
s = "somme"
For L = N To 1 Step -1
v = LCase(r(L).Value)
If InStr(1, v, s) = 0 Then
r(L).EntireRow.Delete
End If
Next L
End Sub
EDIT#1:
The initial version of the macro ignored column C.....try this instead:
Sub SaveSomeRows()
Dim N As Long, L As Long, r As Range
Dim s As String, v As String
Set r = ActiveSheet.Range("D3", ActiveSheet.Range("D65536").End(xlUp))
N = r.Count
s = "somme"
For L = N To 1 Step -1
v = LCase(r(L).Value & r(L).Offset(-1, 0).Value)
MsgBox v
If InStr(1, v, s) = 0 Then
r(L).EntireRow.Delete
End If
Next L
End Sub
I seem to be getting a type mismatch error when trying to do something like this:
In new workbook:
A1 B1
5 4
Function Test1() As Integer
Dim rg As Range
Set rg = Test2()
Test1 = rg.Cells(1, 1).Value
End Function
Function Test2() As Range
Dim rg As Range
Set rg = Range("A1:B1")
Test2 = rg
End Function
Adding =Test1() should return 5 but the code seems to terminate when returning a range from test2(). Is it possible to return a range?
A range is an object. Assigning objects requires the use of the SET keyword, and looks like you forgot one in your Test2 function:
Function Test1() As Integer
Dim rg As Range
Set rg = Test2()
Test1 = rg.Cells(1, 1).Value
End Function
Function Test2() As Range
Dim rg As Range
Set rg = Range("A1:B1")
Set Test2 = rg '<-- Don't forget the SET here'
End Function
You can also return a Variant() which represents an array of values. Here is an example for a function that reverses values from a range into a new range:
Public Function ReverseValues(ByRef r_values As Range) As Variant()
Dim i As Integer, j As Integer, N As Integer, M As Integer
Dim y() As Variant
N = r_values.Rows.Count
M = r_values.Columns.Count
y = r_values.value 'copy values from sheet into an array
'y now is a Variant(1 to N, 1 to M)
Dim t as Variant
For i = 1 To N / 2
For j = 1 To M
t = y(i, j)
y(i, j) = y(N - i + 1, j)
y(N - i + 1, j) = t
Next j
Next i
ReverseValues = y
End Function
In the worksheet you have to apply this function as an array formula (with Ctrl-Shift-Enter) with an appropriate number of cells selected. The details of the Swap() function are not important here.
Note that for many rows, this is very efficient. Doing the x = Range.Value and Range.Value = x operations when x is an array and the range contains multiple rows columns is many times faster than doing the operations one by one directly on the cells.
Change last line in Test2 to:
Set Test2 = rg
This also works
Function Test2(Rng As Range) As Range
Set Test2 = Rng
End Function