VBA Rows.Count in Selection - vba

I'm looking to work out how many rows a user has selected to be displayed at the top of the sheet next to an action button, I.e. Button says "Generate Email" and next to it says "x items selected".
As this is updated everytime the selection is changed, I have the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("E1") = Target.Rows.Count & " items selected"
End Sub
This works fine if the user selects consecutive rows, for e.g. 7:10 returns 4.
My problem is if a user selected rows 7, and 10. It would only return 1 (the rows in the first part of the selection).
From what I've found, there is no way of just getting this value from a property, but I can't get my head around how to iterate through all parts of the selection/target and calculate the sum of rows. Then there is also the possibility that the user selects say A7, C7, and A10. A7 and C7 relate to the same item, so this should only really be treated as one, not two, which I think my hypothetical code would do...
Has anyone tried to achieve this before and been successful or could point me in the direction of some properties which may help? I tried a separate function to achieve it, but that wasn't working either.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("E1") = getRowCount(Target) & " items selected"
End Sub
Function getRowCount(selectedRanges As Ranges)
rowCount = 0
For Each subRange In selectedRanges
rowCount = rowCount + subRange.Rows.Count
Next
getRowCount = rowCount
End Function

I think this will work. (Did when I tried it.)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Create a range containing just column A
Dim subRange As Range
Dim r As Range
For Each subRange In Target.Areas
If r Is Nothing Then
Set r = subRange.EntireRow.Columns(1)
Else
Set r = Union(r, subRange.EntireRow.Columns(1))
End If
Next
'Count how many cells in the combined column A range
Sheet1.Range("E1") = r.Cells.Count & " items selected"
End Sub

You need to count the rows in each Area the user has selected.
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-areas-property-excel
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rArea As Range
Dim lCount As Long
For Each rArea In Selection.Areas
lCount = lCount + rArea.Rows.Count
Next rArea
Sheet1.Range("E1") = lCount
End Sub

Sub NumberOfRowsSelected()
Dim vMatch As Variant, aRows() As Long, r As Range, x As Long
ReDim Preserve aRows(x)
aRows(x) = 0
For Each r In Selection.Cells
vMatch = Application.Match(r.Row, aRows, 0)
If IsError(vMatch) Then
x = x + 1
ReDim Preserve aRows(0 To x)
aRows(x) = r.Row
End If
Next r
MsgBox UBound(aRows)
End Sub
Revised Code Converted as Function
Sub NumberOfRowsSelected()
MsgBox RowsCount(Selection)
End Sub
Function RowsCount(rRange As Range) As Long
Dim vMatch As Variant, aRows() As Long, r As Range, x As Long
ReDim Preserve aRows(x)
aRows(x) = 0
For Each r In rRange.Cells
vMatch = Application.Match(r.Row, aRows, 0)
If IsError(vMatch) Then
x = x + 1
ReDim Preserve aRows(0 To x)
aRows(x) = r.Row
End If
Next r
RowsCount = UBound(aRows)
End Function

A different method, building up a string of checked rows seems pretty straight-forward to avoid double counting. See comments for details:
Function getRowCount(rng As Range) As Long
Dim c As Range
' Keep track of which rows we've already counted
Dim countedrows As String: countedrows = ","
' Loop over cells in range
For Each c In rng
' Check if already counted
If Not InStr(countedrows, "," & c.Row & ",") > 0 Then
' Add to counted list
countedrows = countedrows & c.Row & ","
End If
Next c
' Get number of rows counted
Dim rowsarr() As String: rowsarr = Split(countedrows, ",")
getRowCount = UBound(rowsarr) - LBound(rowsarr) - 1
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
Dim i, currentRow As Long: i = 0
'get row of first cell in range
currentRow = Target.Cells(1, 1).row
For Each cell In Target
'if row is different, then increase number of items, as it's next item
If Not currentRow = cell.row Then
i = i + 1
currentRow = cell.row
End If
Next cell
Range("E1").Value = i
End Sub

Related

Excel VBA Large Table, Add Comments Vlookup, After Hitting Command Button

I have a large table and the information I'm wanting to add comments to falls within Range(D11:CY148). I have two tabs - "Finish Matrix" (main) and "list" (hidden - has 2 columns).
I have two issues.
First issue - Code works to a degree, after I type my values within a cell it automatically adds comments based off info in another sheet. The problem is there is too many cells to be manually typing into and if I copy and paste the code doesn't run. I created a CommandButton and wanted it to refresh the entire table with comments depending if the cells had the values that fall within "list". I tried to create a call out to Worksheet_Change but to no avail. (I'm a beginner so it'll help if you explain)
Second issue - I'm assuming it'll get fixed with whatever suggestion that works. Occasionally after typing into a cell I would get an error. Can't remember the error name but it is one of the common ones, atm the error isn't popping up but surely it'll come back since I didn't do anything different to the code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:CX")) Is Nothing Then _
If Intersect(Target, Columns("CY")) Is Nothing Then Exit Sub
Dim lRow As Integer
lRow = Sheets("list").Range("A1").End(xlDown).Row
If Target.Value = vbNullString Then Target.ClearComments
For Each cell In Sheets("list").Range("A1:A" & lRow)
If cell.Value = Target.Value Then
Target.AddComment
Target.Comment.Text Text:=cell.Offset(0, 1).Value
End If
Next cell
End Sub
Thanks for any and all help!
You are basically missing the For Each Cell in Target part...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMain As Worksheet, wsList As Worksheet
Dim cell As Range
Dim vCommentList As Variant
Dim i As Long, lLastRow As Long
Dim sValue As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsMain = Target.Parent
Set Target = Intersect(Target, wsMain.Range("D11:CY148"))
If Target Is Nothing Then Exit Sub
Set wsList = wsMain.Parent.Sheets("list")
lLastRow = LastRow(1, wsList)
' Read Comment List into Variant (for speed)
vCommentList = wsList.Range("A1:B" & lLastRow)
Target.ClearComments
' This...For each Cell in Target...is what you were missing.
For Each cell In Target
sValue = cell
For i = 1 To UBound(vCommentList)
If sValue = vCommentList(i, 1) Then
AddComment cell, CStr(vCommentList(i, 2))
Exit For
End If
Next
Next
ErrHandler:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Proper way to find last row ...
Public Function LastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
LastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
Add Comment Sub the allows appending is needed...
Public Sub AddComment(Target As Range, Text As String)
If Target.Count = 1 Then
If Target.Comment Is Nothing Then
Target.AddComment Text
Else
Target.Comment.Text Target.Comment.Text & vbLf & Text
End If
End If
End Sub
Untested, but this will take all the values in Range(D11:CY148) and add a comment based on a lookup from Sheet "list".
Sub testy()
Dim arr As Variant, element As Variant
Dim i As Long, j As Long, listItems As Long, rwLast As Long, clLast As Long
Dim comm As String
Dim rng As Range, cell As Range
listItems = Sheets("list").Range("A1").End(xlDown).Row
rwLast = Cells.SpecialCells(xlCellTypeLastCell).Row ' Adjust to fit your needs
clLast = Cells.SpecialCells(xlCellTypeLastCell).Column 'Idem
Set rng = Sheets("list").Range("A1:A" & listItems)
arr = Range("D11:CY148").Value
With Worksheets("Finish Matrix")
For i = 1 To rwLast - 10 'Adjust to make it more general, this is pretty rough
For j = 1 To clLast - 3 'Idem
If i = 3 Then
End If
comm = ""
For Each cell In rng
If arr(i, j) = cell.Value Then
comm = comm & Chr(13) & cell.Offset(0, 1).Value
End If
Next cell
If Not (comm = "") Then
.Cells(10, 3).Offset(i, j).ClearComments
.Cells(10, 3).Offset(i, j).AddComment
.Cells(10, 3).Offset(i, j).Comment.Text Text:=comm
End If
Next j
Next i
End With
End Sub

EXCEL VBA | Cell equals selection

I've a question about showing a Selection value inside a specific cell in my sheet.(let's call it J1 for now)
So, If the user drag-selected (by mouse) A1,A2,A3,A4. J1 value will show "A1:A4", after then with some VBA code I concatenate these cells to show cells values separated by ";".
The problem is, when the user selects cells which is not in order (by holding CTRL), Like A1,A5,A11. J1 value will shows "A1,A5,A11" when I concatenate, it gives "#VALUE" error.
Can we just replace every cell reference here with cell value?
and leave the "comma" in between as is.
then later we can Subtitute comma with ";"
Excuse me if my question seems a little bit ignorant :)
my code for selection:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
Dim s As String
Set rng = Application.Selection
If rng.Count < 2 Then
Range("H1").Value = Cells(Target.Row, Target.Column).Value
Else
Range("H1").Value = rng.Address
End If
End Sub
Code for Concatenation:
Function ConcatenateRange(ByVal cell_range As Range, _
Optional ByVal seperator As String) As String
Dim cell As Range
Dim lastrow
Dim choice
Dim lastrowmodified
Dim rangy
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
cellArray = cell_range.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j)) & ";"
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
If I understand correctly, you want the one cell, say J1 to contain all values of selected cells, separated by a semi colon? If so, you can just modify your first sub,
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
Set rng = Application.Selection
Dim vCell as Range
Range("J1").Value = ""
' Cycle through cells in range
For each vCell in rng
' Use if so that J1 doesn't start with a semi colon
If Range("J1").Value = "" Then
Range("J1").Value = vCell.Value
Else
Range("J1").Value = Range("J1").Value & ";" & vCell.Value
End If
Next vCell
End Sub
Another method would be to use a string array in conjunction with a JOIN function. This works for non-contiguous selections:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c as Range, i as Integer
Dim arr() As String
ReDim arr(0 To Selection.Count - 1) As String
If Selection.Count < 2 Then
Range("J1").Value = Selection.Value
Else
For Each c In Selection.Cells
arr(i) = c.Value
i = i + 1
Next c
Range("J1").Value = Join(arr, ";")
End if
End Sub

Deleting Duplicate Visible Rows

I am trying to use the following VBA code to do two things.
Count the number of unique visible rows in a filtered worksheet.
Delete the duplicate rows
So far:
Function UniqueVisible(MyRange As Range) As Integer
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim R As Range
Dim V() As String
ReDim V(0 To MyRange.Count) As String
For Each R In MyRange
If (R.EntireRow.Hidden = False) Then
For Index = 0 To UniqueVisible
If (V(Index) = R.Value) Then
R.Delete
Exit For
End If
If (Index = UniqueVisible) Then
V(UniqueVisible) = R.Value
UniqueVisible = UniqueVisible + 1
End If
Next
End If
Next R
End Function
This counts okay, and if I replace R.Delete with MsgBox(R.Row) I get the correct row number of the duplicate.
R.Delete does nothing.
R.EntireRow.Delete does nothing
ws.Rows(R.Row).Delete does nothing.
UPDATE
This doesn't seem to be working
Function UniqueVisible(MyRange As Range) As Integer
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim R As Range
Dim Dup As Integer
Dup = 0
Dim Dups() As Integer
ReDim Dups(0 To MyRange.Count) As Integer
Dim V() As String
ReDim V(0 To MyRange.Count) As String
For Each R In MyRange
If (R.EntireRow.Hidden = False) Then
For Index = 0 To UniqueVisible
If (V(Index) = R.Value) Then
Dups(Dup) = R.Row
Dup = Dup + 1
Exit For
End If
If (Index = UniqueVisible) Then
V(UniqueVisible) = R.Value
UniqueVisible = UniqueVisible + 1
End If
Next
End If
Next R
For Each D In Dups
ws.Rows(D).Delete
Next D
End Function
It seems you're breaking a few rules here.
You cannot use a function to delete rows in VBA. It does not matter whether you are using the function as a User Defined Function (aka UDF) on the worksheet or calling it from a sub in a VBA project. A function is meant to return a value, not perform operations that modify the structure (or even the values other than its own cell) on a worksheet. In your case, it could return an array of row numbers to be deleted by a sub.
It is considered canonical practise to start from the bottom (or the right for columns) and work up when deleting rows. Working from the top to the bottom may skip rows when a row is deleted and you loop to the next one.
Here is an example where a sub calls the function to gather the count of the unique, visible entries and an array of rows to be removed.
Sub remove_rows()
Dim v As Long, vDelete_These As Variant, iUnique As Long
Dim ws As Worksheet
Set ws = Worksheets(1)
vDelete_These = UniqueVisible(ws.Range("A1:A20"))
iUnique = vDelete_These(LBound(vDelete_These))
For v = UBound(vDelete_These) To (LBound(vDelete_These) + 1) Step -1 'not that we are working from the bottom up
ws.Rows(vDelete_These(v)).EntireRow.Delete
Next v
Debug.Print "There were " & iUnique & " unique, visible values."
End Sub
Function UniqueVisible(MyRange As Range)
Dim R As Range
Dim uniq As Long
Dim Dups As Variant
Dim v As String
ReDim Dups(1 To 1) 'make room for the unique count
v = ChrW(8203) 'seed out string hash check with the delimiter
For Each R In MyRange
If Not R.EntireRow.Hidden Then
If CBool(InStr(1, v, ChrW(8203) & R.Value & ChrW(8203), vbTextCompare)) Then
ReDim Preserve Dups(1 To UBound(Dups) + 1)
Dups(UBound(Dups)) = R.Row
Else
uniq = uniq + 1
v = v & R.Value & ChrW(8203)
End If
End If
Next R
Dups(LBound(Dups)) = uniq 'stuff the unique count into the primary of the array
UniqueVisible = Dups
End Function
Now, that is probably not how I would go about it. Seems easier to just write the whole thing into a single sub. However, understanding processes and limitations is important so I hope you can work with this.
Note that this does not have any error control. This should be present when dealing with arrays and deleting row in loops.
You can't delete a row while you're looping through the rows. You'll need to store the rows that need to be deleted in an array, and then loop through the array and delete the rows after it's done looping through the rows.

Finding the next value in a range

I'm looking to have a user activated "Next Site" button that advances the value of a cell through a defined range of cells from another sheet. Everytime the button is pressed it should return the value of the next item in the range
So far I have :
Sub NextSite()
Set EXCEPTION = Sheets("EXCEPTION")
Set CONTROL = Sheets("CONTROL")
Dim rCell As Range
Dim rRng As Range
CurrentVal = EXCEPTION.Range("B16")
Set rRng = CONTROL.Range("B9:B72")
For Each rCell In rRng.Cells
If CurrentVal = rCell.Value Then
GoTo NextCell
Else
ActiveCell.Formula = CONTROL.Range(rCell.Address)
Exit For
End If
NextCell:
Next rCell
End Sub
While I think I have the beginning of an idea here I can't quite get the flow of working through the range.
I would also like to have the a separate code that finds the previous Site in the list if anyone can offer advice for that.
Interesting question..In this example we want to sequentially sample from a range called rLook. The range is a disjoint set of cells (the worst case), but the macro will work on any range. We use a static variable to sample index:
Dim Kounter As Long
Sub sequentialSamples()
Dim rLook As Range, r As Range
Set rLook = Sheets("Sheet2").Range("A1,B9,C13,F1,J66")
If Kounter = 0 Or Kounter > rLook.Count Then
Kounter = 1
End If
j = 0
For Each r In rLook
j = j + 1
If j = Kounter Then
MsgBox Kounter & vbCrLf & r.Address & vbCrLf & r.Value
Kounter = Kounter + 1
Exit Sub
End If
Next r
End Sub

Count number of different cells in VBA

I want to count no of different cells which are selected using VBA.
Consider if we select five distinct cells - D5, C2, E7, A4, B1.
Is there a way I can count these number of cells.
Secondly how can I retrieve data in these cells. Lets say I want to store it in an array.
Thank you for the help.
Dim rngCell as Range, arrArray() as Variant, i as integer
Redim arrArray(1 to Selection.Cells.Count)
i = 1
For each rngCell in Selection
arrArray(i) = rngCell.Value
i = i + 1
Next
Looks like you got it mostly figured out, but here is something to load it into an array if you want it:
Public Sub Example()
Dim test() As Variant
test = RangeToArray(Excel.Selection, True)
MsgBox Join(test, vbNewLine)
End Sub
Public Function RangeToArray(ByVal rng As Excel.Range, Optional ByVal skipBlank As Boolean = False) As Variant()
Dim rtnVal() As Variant
Dim i As Long, cll As Excel.Range
ReDim rtnVal(rng.Cells.Count - 1)
If skipBlank Then
For Each cll In rng.Cells
If LenB(cll.Value) Then
rtnVal(i) = cll.Value
i = i + 1
End If
Next
ReDim Preserve rtnVal(i - 1)
Else
For Each cll In rng.Cells
rtnVal(i) = cll.Value
i = i + 1
Next
End If
RangeToArray = rtnVal
End Function
Thankfully I got a way around it by doing - Selection.Cells.Count
It returns me the cell count for selected cells.
But I am still stuck with dynamically assigning this value to an array as in ---
I = Selection.Cells.Count Dim ValArr(I)