How do I get a cell's position within a range? - vba

How would I go about getting the relative position of a cell within a range? Finding the position of a cell in a worksheet is trivial, using the Row- and Column-properties, but I am unsure of how to do the same within a range.
I considered using the position of the top-left cell in the range I want to find the position of a cell in, and just deduct it (-1) from the position of the cell in the worksheet, but it gets a little bit cumbersome. Is there a more elegant way to go about this?
My best attempt, including a test, so far is this:
Option Explicit
Sub test()
Dim r As Range: Set r = Sheet1.Range("B2:E10")
Dim c As Range: Set c = Sheet1.Range("C2")
Debug.Print "Column in sheet: " & c.Column
Debug.Print "Row in sheet: " & c.Row
Debug.Print "Column in range: " & column_in_range(r, c)
Debug.Print "Row in range: " & row_in_range(r, c)
End Sub
Function column_in_range(r As Range, c As Range) As Long
column_in_range = c.Column - (r.Cells(1, 1).Column - 1)
End Function
Function row_in_range(r As Range, c As Range) As Long
row_in_range = c.Row - (r.Cells(1, 1).Row - 1)
End Function
This gives the desired output:
Column in sheet: 3
Row in sheet: 2
Column in range: 2
Row in range: 1
But I wonder if there are any native functions I can use instead?

updated using variant provided by lori_m
But I wonder if there are any native functions ...
use this
Sub test()
Dim r As Range, c As Range
With Sheet1
Set r = .[B2:E10]
Set c = .[C2]
End With
If Not Intersect(r, c) Is Nothing Then
Debug.Print "Column in sheet: " & c.Column
Debug.Print "Row in sheet: " & c.Row
Debug.Print "Column in range: " & Range(r(1), c).Columns.Count
Debug.Print "Row in range: " & Range(r(1), c).Rows.Count
End If
End Sub
output
Column in sheet: 3
Row in sheet: 2
Column in range: 2
Row in range: 1

There is no native way to do it. I also do what you have mentioned in the code above. However I put some extra checks.
Sub test1()
Dim r As Range: Set r = Sheet1.Range("B2:E10")
Dim c As Range: Set c = Sheet2.Range("C2") '<~~ Changed Sheet1 to sheet2
Dim rng As Range
On Error Resume Next
Set rng = Intersect(c, r)
On Error GoTo 0
'~~> Check if the range is in main range
If Not rng Is Nothing Then
'
'~~> Rest of your code
'
Else
MsgBox c.Address & " in " & c.Parent.Name & _
" is not a part of " & _
r.Address & " in " & r.Parent.Name
End If
End Sub

In my opinion there is almost native way to check it but result is a string required some additional manipulation. All you need to use is a proper construction of .Address property (according to MSDN). Some examples:
Dim r As Range: Set r = Sheet1.Range("B2:E10")
Dim c As Range: Set c = Sheet1.Range("c2")
Debug.Print c.Address(False, False, xlR1C1, , r.Cells(0, 0))
'>>result: R[1]C[2]
'-----------------------------------------------------
Set c = Sheet1.Range("e2")
Debug.Print c.Address(False, False, xlR1C1, , r.Cells(0, 0))
'>>result: R[1]C[4]
'-----------------------------------------------------
Set c = Sheet1.Range("e5")
Debug.Print c.Address(False, False, xlR1C1, , r.Cells(0, 0))
'>>result: R[4]C[4]
'-----------------------------------------------------

Take a look on MSDN to see more.
You can use something like :
MsgBox ActiveCell.Address(RowAbsolute:=True, _
ColumnAbsolute:=True, _
ReferenceStyle:=xlR1C1, _
External:=False, _
RelativeTo:=Range("B2"))
'Or shorter version :
MsgBox ActiveCell.Address(, , xlR1C1, False, Range("B2"))
But you'll have both information about row and column in the range, but not separately.
So you'll still need to extract these values from the answer (look like : R18C20) in two functions, so almost the same issue...

I'm not totally sure if this is what you are after.
But here it goes:
Sub ts2()
Dim test As Range
Set test = Range("B2:E10")
Dim topcorner As Range
Dim testcell As Range
Set topcorner = Cells(test.Row, test.Column)
Set testcell = Range("D7")
rel_row = testcell.Row - topcorner.Row
rel_col = testcell.Column - topcorner.Column
End Sub
By this, you will find the relative position.
But maybe you were looking for some built in function ?
If this was not the thing you were after, please edit your post...

Related

Count blank cells in multiple column using array VBA

I have written a code which gives me exact count of empty/blank cells in a column/s.
This shows the results if I run the code for column A
Sub countblank()
Const column_to_test = 2 'column (B)
Dim r As Range
Set r = Range(Cells(2, column_to_test), Cells(Rows.Count,
column_to_test).End(xlUp))
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows
with blank cells in column B")
Const columns_to_test = 3 'column (C)
Set r = Range(Cells(3, columns_to_test), Cells(Rows.Count,
columns_to_test).End(xlUp))
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows
with blank cells in column c ")
'and so on i can count the blanks for as many columns i want
End Sub
But the problems are as follows:-
If there are no blanks, this macro will throw an error and will terminate itself. What if I want to run the remaining code?
Using array or something equivalent I want to search the multiple columns by header at the same time, instead of column number that to separately as shown in the code.
If a blank/s is found it pops a Msgbox but can we get the list of error in a separate new sheet called "error_sheet"?
Function getBlanksInListCount(ws As Worksheet, Optional FirstRow = 2, Optional TestColumn = 2)
With ws
getBlanksInListCount = WorksheetFunction.countblank(.Range(.Cells(FirstRow, TestColumn), .Cells(.Rows.Count, TestColumn).End(xlUp)))
End With
End Function
Try this
Sub countblank()
Dim i As Long
For i = 2 To 10 ' for looping through the columns
Dim r As Range
Set r = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
'for not getting error and adding error messages in the error_sheet
'MsgBox ("There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column)
Sheets("error_sheet").Range(r.Address).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
Next i
End Sub
Try sub MAIN to examine the first three columns:
Sub countblank(column_to_test As Long)
Dim r As Range, rr As Range, col As String
col = Split(Cells(1, column_to_test).Address, "$")(1)
Set r = Range(Cells(2, column_to_test), Cells(Rows.Count, column_to_test).End(xlUp))
On Error Resume Next
Set rr = r.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rr Is Nothing Then
MsgBox ("There are no Rows with blank cells in column " & col)
Else
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows with blank cells in column " & col)
End If
End Sub
Sub MAIN()
Dim i As Long
For i = 1 To 3
Call countblank(i)
Next i
End Sub
Q1 can be answered by using an error handling statement. Error handling statements can be as simple or complicated as one would like them to be. The one below is probably my first go to method.
' if no blank cells found, code continues
On Error Resume Next
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & _
" Rows with blank cells in column B")
Using headers would work fine. Please see final answer below for this method.
This answer is a minor change from the answer submitted by Imran Malek
Sub countblank()
Dim i As Long
' new integer "row" declared
Dim row As Integer
' new integer "row" set
row = 1
For i = 2 To 4 ' for looping through the columns
Dim r As Range
Set r = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
'for not getting error and adding error messages in the error_sheet
'MsgBox ("There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column)
' using the value in row to insert our output
Sheets("error_sheet").Range("A" & row).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
' adding 1 to "row" to prep for next output
row = row + 1
Next i
End Sub
Final answer: My apologies for the lengthy answer. This answer is a modification of Imran Malek's answer, found in the link of answer 3. Please note, this version does not contain error handling, explained in Q1.
Sub countblank()
Dim Header(1 To 4) As String
Header(1) = "Name"
Header(2) = "Age"
Header(3) = "Salary"
Header(4) = "Test"
Dim i As Integer
Dim row As Integer
Dim r As Range
Dim c As Integer
row = 1
' **NOTE** if you add any more values to {Header}, the loop has to be equal to the Header count
' i.e. 4 {Headers}, 4 in the loop
For i = 1 To 4
'looking for the header in row 1
c = Cells(1, 1).EntireRow.Find(What:=Header(i), LookIn:=xlValues).Column
'defining the column after header is found
Set r = Range(Cells(2, c), Cells(Rows.Count, c).End(xlUp))
' using the value in row to insert our output
Sheets("error_sheet").Range("A" & row).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
' adding 1 to "row" to prep for next output
row = row + 1
Next i
End Sub

custom made functions in VBA

I have a list of films and their durations in minutes. I wish to create a custom function whereby the user selects the range of durations i.e. one or more cells. The function converts the duration in minutes into " x hours and y minutes form ".
I have created the following function but it does not seem to take more than 1 cell reference at a time.
Function Saikatrealtime(cell As Range) As String
Dim r As String
r = Int(cell.Value / 60) & " hours " & " & " & cell.Value Mod 60 & " minutes "
Saikatrealtime = r
End Function
Sub realtimesof_film()
Dim rng As Range
Dim t As String
s1.Activate
Set rng = Application.InputBox(prompt:=" enter range ", Type:=8)
t = Saikatrealtime(rng)
rng.Offset(0, 2).Value = t
End Sub
Whenever I give a reference to rng as 2 or more cells, it gives the error type mismatch at the line
r = Int(cell.Value / 60) & " hours " & " & " & cell.Value Mod 60 & " minutes "
Can anyone please tell me how I can modify the code so that the function runs across multiple cell references given to rng?
Unless you change the formula to return an array of values, you'll have to modify the subroutine code to reference multi-cell ranges. Adding a loop of the cells within the range will work. Add this to your subroutine:
Dim Cell As Range
For Each Cell In rng.Cells
Cell.Offset(0, 2).Value = Saikatrealtime(Cell)
Next Cell
There is no need for the custom function Saikatrealtime. You can use Format instead. The key is that you have to escape certain letters in the text using a backslash \
Sub realtimesof_film()
Dim rng As Range
Dim c As Range
Set rng = Application.InputBox(prompt:=" enter range ", Type:=8)
For Each c In rng
c.Offset(0, 2).Value = Format(c.Value, "HH \hour\s & MM \mi\nute\s ")
Next
End Sub

excel vba - Using autofilter - can't pass the filtered range to a sub, it keeps passing the entire sheet range

I can't seem to figure this one out. I have a function and a sub where I call the function to get the unique values (from column N (text values)) from the range I've already selected from the autofilter. Somehow, the range keeps being the entire sheet range and not the selected.
Function UniquesFromRange(rng As Range)
Dim d As Object, c As Range, tmp
Set d = CreateObject("scripting.dictionary")
For Each c In rng.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 Then
If Not d.Exists(tmp) Then d.Add tmp, 1
End If
Next c
UniquesFromRange = d.Keys
End Function
Sub mainSub()
For Each key In fCatId.Keys
With wshcore
llastrow = wshcore.Range("A" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
.Range("A1:N" & llastrow).AutoFilter
.Range("A1:N" & llastrow).AutoFilter Field:=1, Criteria1:=fCatId(key)
lwmin = WorksheetFunction.Subtotal(5, Range("H:H"))
lwmax = WorksheetFunction.Subtotal(4, Range("H:H"))
'This does not work, I want to get the unique values from column N
'that are already in the filtered range. So far this shows
'all the values in the column not only the ones already filtered.
varArray = UniquesFromRange(Range("N:N"))
'I've also tried this:
'varArray = UniquesFromRange(Range.Cells)
'Debug.Print fCatId(key) & " - " & key & " " & lwmin & "-" & lwmax & fData(key) & " - " & Join(varArray, vbNewLine)
End With
Next key
Application.ScreenUpdating = True
End Sub
any suggestions?
Instead of
varArray = UniquesFromRange(Range("N:N"))
use
varArray = UniquesFromRange(Range("N1:N" & llastrow).SpecialCells(xlCellTypeVisible))
In response to the additional question asked in the comments, you could copy varArray to another sheet (assumed to already exist, and being referred to by the object wsOutput, and output to be written to column A) as follows
Dim r as Integer
For r = LBound(varArray) To UBound(varArray)
wsOutput.Cells(r, 1).Value = varArray(r)
Next

Excel VBA macro for one column, if true, apply formula to another column

For context:
I would like for the program to look through column B, identify the first "< / >" (which is purely stylistic and can be changed if necessary - it's only used to break up the data) as the start of a week at cell B9 and the next "< / >" (end of the week) at B16. So the range I'm interested in is B10-B15. It would then sum those numbers from J10 to J15 (Earned column) and paste that sum in L16 (Week Total column). The same could then be done with 'Hours' and 'Week Hours'. For the following week (and thereafter) the 'end of the week' "< / >" becomes the start of the week, and the program continues until B200.
I don't have any experience with VBA and so made the following incomplete attempt (based on what I had found online) but felt too out of my depth not to ask for help.
Sub Work()
Dim rng As Range
Dim rngFound As Range
Set rng = Range("B:B")
Set rngFound = rng.Find("</>")
If rngFound Is "</>" Then
If Cell = "</>" Then
End If
End Sub
Thank you for any help and please let me know if I can be clearer or elaborate on something.
The following code will loop through 200 lines, looking for your symbol. When found, it will sum the numbers in column J for rows between the current row and the last symbol.
I've included two lines that will update the formula. To me, the 2nd one is easier to understand.
Sub Work()
Dim row As Integer
row = 4
Dim topRowToAdd As Integer 'Remember which row is the
'top of the next sum
topRowToAdd = 4
While row <= 200
If Cells(row, 2) = "</>" Then
'Cells(row, 10).FormulaR1C1 = "=SUM(R[" & -(row - topRowToAdd) & "]C[0]:R[" & -1 & "]C[0])"
Cells(row, 10).Value = "=SUM(J" & topRowToAdd & ":J" & row - 1 & ")"
topRowToAdd = row + 1
End If
row = row + 1
Wend
End Sub
Sub Work()
Dim rng As Range, rngFound As Range
Set rng = Range("B:B")
Set rngFound = rng.Find("</>")
If rngFound.Value2 = "</>" Then
'whatever you want to do
End If
End Sub
So at a second glance it looks like this. If you'd like to make it structured you'd need to use a countifs function first.
Sub Work()
Dim rng As Range, rngFound(1) As Range
Set rng = Range("B1:B200")
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
Set rngFound(1) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(0)) 'finds the first after the first (i.e. the second)
Set rngFound(0) = rngFound(0).Offset(1, 8) '8 is the difference between B and J, row shifts as per description, I advise you to make it a variable
Set rngFound(1) = rngFound(1).Offset(-1, 8)
If rngFound(1).Row > rngFound(0).Row Then 'if it's not higher, then it recurred and found the first range again
rngFound(1).Offset(1, 2).Formula = "=SUM(" & Range(rngFound(0), rngFound(1)).Address & ")" 'L column will have the sum as a formula
Else
MsgBox "There is a single match in " & rng.Address(False, False)
End If
If False Then
Err:
MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub
Now for the grand finale:
Sub Work()
Dim rng As Range, rngFound() As Range, rngdiff(1) As Long, rngcount As Long
Set rng = Range("B1:B200")
rngcount = rng.Cells.Count
ReDim rngFound(rngcount)
rngdiff(0) = Range("J1").Column - rng.Column ' the range that needs to be summed is in column J
rngdiff(1) = Range("L1").Column - rng.Column ' the range containing the formula is in column L
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
'loop starts
For i = 1 To rngcount
Set rngFound(i) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(i - 1)) 'finds the next
If rngFound(i).Row > rngFound(i - 1).Row Then 'if it's not higher, then it recurred and found the first range again
rngFound(i).Offset(0, rngdiff(1)).Formula = "=SUM(" & Range(rngFound(i - 1).Offset(1, rngdiff(0)), rngFound(i).Offset(-1, rngdiff(0))).Address & ")" 'L column will have the sum as a formula
Else
Exit Sub 'if it recurred the deed is done
End If
Next i
If False Then
Err:
MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub

How can I go through all the formulas and array formulas of a worksheet without repeating each array formula many times?

I would like to write a VBA function, which outputs a list of all the single formulas and array formulas of a worksheet. I want an array formula for a range to be printed for only one time.
If I go through all the UsedRange.Cells as follows, it will print each array formula for many times, because it covers several cells, that is not what I want.
For Each Cell In CurrentSheet.UsedRange.Cells
If Cell.HasArray Then
St = Range(" & Cell.CurrentArray.Address & ").FormulaArray = " _
& Chr(34) & Cell.Formula & Chr(34)
ElseIf Cell.HasFormula Then
St = Range(" & Cell.Address & ").FormulaR1C1 = " _
& Chr(34) & Cell.Formula & Chr(34)
End If
Print #1, St
Next
Does anyone have a good idea to avoid this?
You basically need to keep track of what you've already seen. The easy way to do that is to use the Union and Intersect methods that Excel supplies, along with the CurrentArray property of Range.
I just typed this in, so I'm not claiming that it's exhaustive or bug-free, but it demonstrates the basic idea:
Public Sub debugPrintFormulas()
Dim checked As Range
Dim c As Range
For Each c In Application.ActiveSheet.UsedRange
If Not alreadyChecked_(checked, c) Then
If c.HasArray Then
Debug.Print c.CurrentArray.Address, c.FormulaArray
Set checked = accumCheckedCells_(checked, c.CurrentArray)
ElseIf c.HasFormula Then
Debug.Print c.Address, c.Formula
Set checked = accumCheckedCells_(checked, c)
End If
End If
Next c
End Sub
Private Function alreadyChecked_(checked As Range, toCheck As Range) As Boolean
If checked Is Nothing Then
alreadyChecked_ = False
Else
alreadyChecked_ = Not (Application.Intersect(checked, toCheck) Is Nothing)
End If
End Function
Private Function accumCheckedCells_(checked As Range, toCheck As Range) As Range
If checked Is Nothing Then
Set accumCheckedCells_ = toCheck
Else
Set accumCheckedCells_ = Application.Union(checked, toCheck)
End If
End Function
The following code produces output like:
$B$7 -> =SUM(B3:B6)
$B$10 -> =AVERAGE(B3:B6)
$D$10:$D$13 -> =D5:D8
$F$14:$I$14 -> =TRANSPOSE(D5:D8)
I'm using a collection but it could equally well be a string.
Sub GetFormulas()
Dim ws As Worksheet
Dim coll As New Collection
Dim rngFormulas As Range
Dim rng As Range
Dim iter As Variant
Set ws = ActiveSheet
On Error Resume Next
Set rngFormulas = ws.Range("A1").SpecialCells(xlCellTypeFormulas)
If rngFormulas Is Nothing Then Exit Sub 'no formulas
For Each rng In rngFormulas
If rng.HasArray Then
If rng.CurrentArray.Range("A1").Address = rng.Address Then
coll.Add rng.CurrentArray.Address & " -> " & _
rng.Formula, rng.CurrentArray.Address
End If
Else
coll.Add rng.Address & " -> " & _
rng.Formula, rng.Address
End If
Next rng
For Each iter In coll
Debug.Print iter
'or Print #1, iter
Next iter
On Error GoTo 0 'turn on error handling
End Sub
The main difference is that I am only writing the array formula to the collection if the current cell that is being examined is cell A1 in the CurrentArray; that is, only when it is the first cell of the array's range.
Another difference is that I am only looking at cells that contain formulas using SpecialCells, which will be much more efficient than examining the UsedRange.
The only reliable solution I see for your problem is crosschecking each new formula against the ones already considered to make sure that there is no repetition. Depending upon the amount of information and speed expectations you should rely on different approaches.
If the size is not too important (expected number of records below 1000), you should rely on arrays because is the quickest option and its implementation is quite straightforward. Example:
Dim stored(1000) As String
Dim storedCount As Integer
Sub Inspect()
Open "temp.txt" For Output As 1
For Each Cell In CurrentSheet.UsedRange.Cells
If Cell.HasArray Then
St = Range(" & Cell.CurrentArray.Address & ").FormulaArray = " _
& Chr(34) & Cell.Formula & Chr(34)
ElseIf Cell.HasFormula Then
St = Range(" & Cell.Address & ").FormulaR1C1 = " _
& Chr(34) & Cell.Formula & Chr(34)
End If
If(Not alreadyAccounted(St) And storedCount <= 1000) Then
storedCount = storedCount + 1
stored(storedCount) = St
Print #1, St
End If
Next
Close 1
End Sub
Function alreadyAccounted(curString As String) As Boolean
Dim count As Integer: count = 0
Do While (count < storedCount)
count = count + 1
If (LCase(curString) = LCase(stored(count))) Then
alreadyAccounted = True
Exit Function
End If
Loop
End Function
If the expected number of records is much bigger, I would rely on file storage/checking. Relying on Excel (associating the inspected cells to a new range and looking for matches in it) would be easier but slower (mainly in case of having an important number of cells). Thus, a reliable and quick enough approach (although much slower than the aforementioned array) would be reading the file you are creating (a .txt file, I presume) from alreadyAccounted.