VBA Function to find Activecell Table Row - excel

As a learning exercise & possible use in future code I have created my first Excel VBA function to return the activecell row number in any Excel Table (as opposed to the sheet itself) . Essentially it simply finds the active row in the sheet, then finds the row number of the table header which is then subtracted from the cell row number to return the row number of the table which can then be used in subsequent code. However, while it works, it dosen't look the most efficient Can anyone improve it?
Sub TableRow()
Dim LORow As Integer
Dim TbleCell As Range
Set TbleCell = Activecell
Call FuncTableRow(TbleCell, LORow)
MsgBox LORow
End Sub
Public Function FuncTableRow(ByRef TbleCell As Range, LORow As Integer) As Range
Dim LOName As String
Dim LOHeaderRow, Row As Integer
LOName = Activecell.ListObject.Name
Row = Activecell.Row
LOHeaderRow = ActiveSheet.ListObjects(LOName).HeaderRowRange.Row
LORow = Row - LOHeaderRow
Debug.Print (LORow)
End Function

This question will probably get closed for not being specific enough but the most obvious item (to me) is your usage of a custom function. Your function is not actually returning anything, it's only running a debug print. To have your function actually return the row number, you would set it as a type Long (not integer) and include the function name = to the number.
I didn't actually test your function but assuming LORow is dubug printing the proper answer then it should work like this:
Public Function FuncTableRow(ByRef TbleCell As Range, LORow As Integer) As Long
Dim LOName As String
Dim LOHeaderRow, Row As Integer
LOName = Activecell.ListObject.Name
Row = Activecell.Row
LOHeaderRow = ActiveSheet.ListObjects(LOName).HeaderRowRange.Row
LORow = Row - LOHeaderRow
Debug.Print (LORow)
FuncTableRow = LORow
End Function
You also don't Call a function, you can just insert it as itself in a subroutine.
You are using LORow as an input variable but then changing it. That's typically a bad practice.
You should not be using ActiveSheet grab the worksheet from TbleCell.Worksheet
You would almost never use activecell as part of a Custom Formula.
Dim LOHeaderRow, Row As Integer should actually be Dim LOHeaderRow as Long, Row As Long. As you currently have it LOHeaderRow is undefined/Variant.
There's probably more. I would restart your process with a simpler task of returning the last used cell in a worksheet. There's a dozen ways to do this and lots of help examples.

Take a look at this TheSpreadsheetGuru.
Here are some variables that might help you.
Sub TableVariables()
Dim ol As ListObject: Set ol = ActiveSheet.ListObjects(1)
Dim olRng As Range: Set olRng = ol.Range ' table absolute address
Dim olRngStr As String: olRngStr = ol.Range.Address(False, False) ' table address without absolute reference '$'
Dim olRow As Integer: olRow = ol.Range.Row ' first row position
Dim olCol As Integer: olCol = ol.Range.Column ' first column position
Dim olRows As Long: olRows = ol.Range.Rows.Count ' table rows including header
Dim olCols As Long: olCols = ol.ListColumns.Count ' table columns
Dim olListRows As Long: olListRows = ol.ListRows.Count ' table rows without header
End Sub

Related

WorksheetFunction.Sum returning zero for numbers [duplicate]

This question already has answers here:
VBA WorksheetFunction.Sum doesn't work with array but works with range?
(2 answers)
Closed 3 years ago.
Clean up your code, kiddies. After much wailing and gnashing of teeth, the problem turned out to be the extra parentheses I had in my .Sum arguments. Big thanks to #BigBen and #JvdV.
The Problem: Worksheetfunction.Sum returns a sum of 0 for a dynamic range, but only for rows.count > 1 and only for currency-formatted reference data.
More Detail: I have a userform set up to scrape a reference workbook and return a different number into each of four different textboxes based on user input. On occasion the numbers will need to be a sum of several rows on the reference workbook. Using my code below, this works like a dream for every return textbox as long as the number of rows is 1, but returns 0 (or $0.00 as it were) for anything else. However, it works just fine in all circumstances for the one sum that is just an integer. The rest are formatted as currency.
What I've done: Using MsgBoxes I've verified that the dynamic range returns the correct addresses, i.e. all cells I want summed and that the numbers at those addresses are in fact numbers and not text (verified by a True return for IsNumber). I've tried using .Subtotal and .Aggregate to see if those might help, but I ran into Missing Object and other errors and ran away whimpering because I'm new to VBA.
The Code:
My basic logic is as follows: Search in every sheet of the reference (csrWorkbook) for textbox.value. Once found, measure the height of the merged area (I know I know, but the merging decision is made above my paygrade). Offset to the right to find 4 different related quantities. Sum these quantities if multiple rows exist. Return the sum to four different textboxes.
Help!
Private Sub ScrapeButton_Click()
'Enter search term into first TB
'click search button
'result DOES(!!) appear in second TB
'Variables
Dim csrWorkbook As Workbook
Dim refWorkbook As Workbook
Dim refVariables As Worksheet
Dim csrFilePath As String
Dim csrFileName As String
Dim slinAddress As String
Dim ws As Worksheet
Dim sheetCount As Long
Dim rowCount As Long
Dim slinCell As Excel.Range
Dim quantCells As Excel.Range
Dim costCells As Excel.Range
Dim feeCells As Excel.Range
Dim totalCells As Excel.Range
Dim i As Integer
Dim iCost As Double
Dim iFee As Double
Dim iTotal As Double
Set refWorkbook = Workbooks("AutomationBackbone.xlsm")
csrFileName = refWorkbook.Sheets("Variable Storage").Range("A2").Value
Set csrWorkbook = Workbooks(csrFileName)
sheetCount = csrWorkbook.Sheets.Count
'search all worksheets for data in a known column
For i = 1 To sheetCount
Set slinCell = csrWorkbook.Sheets(i).Range("C1:C100").find(Me.TextBox1.Value)
If Not slinCell Is Nothing Then
'Find sums and populate
rowCount = slinCell.MergeArea.Rows.Count 'count the number of rows in merged area
Set quantCells = slinCell.Offset(0, 2).Resize(rowCount, 1) 'establish a new range of that same height
Set costCells = quantCells.Offset(0, 6)
Set feeCells = quantCells.Offset(0, 7)
Set totalCells = quantCells.Offset(0, 8)
Me.iQuantityTB.Value = Application.WorksheetFunction.Sum((quantCells)) 'populate the Initial Quantity
iCost = Application.WorksheetFunction.Sum((costCells)) 'find sum of Cost range
iFee = Application.WorksheetFunction.Sum((feeCells)) 'find sum of Fee range
iTotal = Application.WorksheetFunction.Sum((totalCells)) 'find sum of Total range
Me.iCostTB.Value = iCost 'populate textboxes
Me.iFeeTB.Value = iFee
Me.iTotalTB.Value = iTotal
'original code commented out to see if being more explicit helped.
'Narrator: it didn't
'Me.iCostTB.Value = Application.WorksheetFunction.Sum((quantCells.Offset(0, 6))) 'populate the Initial Cost
'Me.iFeeTB.Value = Application.WorksheetFunction.Sum((quantCells.Offset(0, 7))) 'populate the Initial Fee
'Me.iTotalTB.Value = Application.WorksheetFunction.Sum((quantCells.Offset(0, 8))) 'populate the Initial Total
Exit Sub
End If
Next i
End Sub
Edit: Pics added for clarity.
Parentheses strike again!
Including the extra parentheses causes the inner expression to be evaluated, and the result to be passed to Sum.
So
Application.WorksheetFunction.Sum((costCells))
is equivalent to
Application.WorksheetFunction.Sum(costCells.Value)
which returns zero when the underlying data is Currency.
As a small reproducible example for Sums behavior here (which is not what I expected):
Dim x(0 To 1) As Currency
x(0) = 1
x(1) = 2
Debug.Print Application.Sum(x) '<~ returns zero.
Note that .Value2 does not use the Currency data type, and the line
Application.WorksheetFunction.Sum(costCells.Value2)
would return the correct result regardless of the underlying value.
Note that similar behavior has been noted and explained here.

VBA Macro to find rows and store in array runs slow

So I made a simple VBA macro to run over ~7000 rows of data - the idea is that .Find finds the cells which contain "1" in column G, so that it can store the row number in an array which I shall later throw back to another sub
Unfortunately the code takes too long to run - it begs the question, have I created an infinite loop in my code? Or is asking it to loop a .find operation over 7000 cells too much for vba to handle at a reasonable speed? (i.e. do I need to improve efficiency in areas?)
Option Explicit
Public Sub splittest()
Dim sheet As Object, wb As Workbook
Dim rangeofvals As Range
Dim pullrange As Variant
Dim c As Long
Dim dynarr() As Variant
Dim xvalue As Long
Dim firstaddress As Variant
Dim count As Long
Set wb = ThisWorkbook
Set sheet = wb.Sheets("imported d")
Set rangeofvals = Range("G1:G6939")
'need to set pull range at some later point
Call OptimizeCode_Begin 'sub which turns off processes like application screen updating
xvalue = 1
ReDim dynarr(3477) 'hardcoded, replace with a countif function at some point
count = 0
With wb.Sheets("imported d").Range("G1:G6939")
c = rangeofvals.Find(xvalue, LookIn:=xlFormulas).Row
If c >= 0 Then
dynarr(count) = c
' MsgBox firstaddress
Do
' MsgBox c
c = rangeofvals.FindNext(Cells(c, 7)).Row
dynarr(count) = c 'apparently redim preserve would be slower
Loop While c >= 0
End If
Call OptimizeCode_End 'sub which turns back on processes switched off before
End With
End Sub
If you know the column is G and all the data is contiguous, then just loop through the rows and check the cell value directly:
Dim rows As New Collection
Dim sheet As Worksheet
Dim lastRow, i As Integer
Set sheet = ThisWorkbook.Sheets("imported d")
lastRow = sheet.Cells(1,7).CurrentRegion.Rows.Count
For i = 1 to lastRow
If (sheet.Cells(i,7).Value = 1) Then
rows.Add i
End If
Next
Unclear how the data is being used in the other sub but collection is definitely more efficient storage object for adding iteratively when the total item count is indeterminate. If you want to convert to an array then you can do so efficiently afterward since the collection tells you the item count. I'm not really sure why you would need an array specifically but I'm not going to tell you not to without seeing the client sub. Also note that the declaration of sheet was changed from Object to Worksheet since it is better to use the specific data type if possible.
...yep it was an infinite loop.
the line:
Loop While c >= 0
caused it as there is never an occasion c is less than 0 - back to the drawing board for me!

Highlight and Remove Partial Duplicates in Excel

I have a spreadsheet that contains over 100k rows in a single column (I know crazy) and I need to find an efficient way to highlight partial duplicates and remove them. All the records are all in the same format, but may have an additional letter attached at the end. I would like to keep the first instance of the partial duplicate, and remove all instances after.
So from this:
1234 W
1234 T
9456 S
1234 T
To This:
1234 W
9456 S
I was going to use the formula below to conditionally highlight the partial dupes, but i receive an error "You may not use reference operators (such as unions....) or array constants for Conditional Formatting criteria" and use VBA to remove those highlighted cells.
=if(A1<>"",Countif(A$1:A,left(A1,4)& "*") > 1)
Any thoughts? I know conditional formatting is memory intensive, so if there's any way to perform this using VBA I'm open to suggestion.
Here is one way to remove the duplicates quickly:
Text to Columns, using space delimiter.
Remove Duplicates referring to duplicates in the first column only.
Merge the content of each row with =Concatenate(A1, B1).
If the "unique identifier" of each value is just its first 4 characters, then maybe the code below will be okay for you.
I recommend making a copy of your file before running any code, as code tries to overwrite the contents of column A. (The procedure to run is PreprocessAndRemoveDuplicates.)
You may need to change the name of the sheet (in the code). I assumed "Sheet1".
Code assumes data is only in column A.
Option Explicit
Private Sub PreprocessAndRemoveDuplicates()
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called. You could use code name instead too.
Dim lastCell As Range
Set lastCell = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp)
Debug.Assert lastCell.Row > 1
Dim inputArray() As Variant
inputArray = targetSheet.Range("A1", lastCell) ' Assumes data starts from A1.
Dim uniqueValues As Scripting.Dictionary
Set uniqueValues = New Scripting.Dictionary
Dim rowIndex As Long
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
Dim currentKey As String
currentKey = GetKeyFromValue(CStr(inputArray(rowIndex, 1)))
If Not uniqueValues.Exists(currentKey) Then ' Only first instance added.
uniqueValues.Add currentKey, inputArray(rowIndex, 1)
End If
Next rowIndex
WriteDictionaryItemsToSheet uniqueValues, targetSheet.Cells(1, lastCell.Column)
End Sub
Private Function GetKeyFromValue(ByVal someText As String, Optional charactersToExtract As Long = 4) As String
' If below logic is not correct/appropriate for your scenario, replace with whatever it should be.
' Presently this just gets the first N characters of the string, where N is 4 by default.
GetKeyFromValue = Left$(someText, charactersToExtract)
End Function
Private Sub WriteDictionaryItemsToSheet(ByVal someDictionary As Scripting.Dictionary, ByVal firstCell As Range)
Dim initialArray() As Variant
initialArray = someDictionary.Items()
Dim arrayToWriteToSheet() As Variant
arrayToWriteToSheet = StandardiseArray(initialArray)
With firstCell
.EntireColumn.ClearContents
.Resize(UBound(arrayToWriteToSheet, 1), UBound(arrayToWriteToSheet, 2)).Value = arrayToWriteToSheet
End With
End Sub
Private Function StandardiseArray(ByRef someArray() As Variant) As Variant()
' Application.Transpose might be limited to ~65k
Dim baseDifference As Long
baseDifference = 1 - LBound(someArray)
Dim rowCount As Long ' 1 based
rowCount = UBound(someArray) - LBound(someArray) + 1
Dim outputArray() As Variant
ReDim outputArray(1 To rowCount, 1 To 1)
Dim readIndex As Long
Dim writeIndex As Long
For readIndex = LBound(someArray) To UBound(someArray)
writeIndex = writeIndex + 1
outputArray(writeIndex, 1) = someArray(readIndex)
Next readIndex
StandardiseArray = outputArray
End Function
Processed 1 million values (A1:A1000000) in under 3 seconds on my machine, but performance on your machine may differ.

Resize non sequential column reference to the first row

Can someone tell me how I can resize a column reference to the first row in a worksheet?
I get errors (for different reasons on both) which is understandable but still frustrating:
Attempt 1:
Dim Columns_To_Export as String
Columns_To_Export ="$B:$C,$E:$E"
Range(Columns_To_Export).Resize(1).Select
Attempt 2:
Dim Columns_To_Export as String
Columns_To_Export ="$B:$C,$E:$E"
Colulumns(Columns_To_Export).Resize(1).Select
I'm afraid I wasn't very attentive with my above response. Here is what I believe is a better try.
Private Sub SelectCells()
On Error Resume Next
Debug.Print CellsForExport("$B:$C, $E:$E, G").Address
End Sub
Function CellsForExport(ByVal Desc As String) As Range
' 15 Apr 2017
Dim Fun As Range, Rng As Range
Dim Spi() As String, Spj() As String
Dim i As Integer, j As Integer
Dim Cstart As Long, Cend As Long
Desc = Replace(Desc, "$", "")
Spi = Split(Desc, ",")
For i = 0 To UBound(Spi)
Spj = Split(Trim(Spi(i)), ":")
Cstart = Columns(Trim(Spj(0))).Column
Cend = Cstart
If UBound(Spj) Then Cend = Columns(Trim(Spj(1))).Column
With ActiveSheet.Rows(1)
Set Rng = .Range(.Cells(Cstart), .Cells(Cend))
End With
If Fun Is Nothing Then
Set Fun = Rng
Else
Set Fun = Application.Union(Fun, Rng)
End If
Next i
Set CellsForExport = Fun
End Function
The function CellsForExport returns a range as specified by the calling procedure SelectCells. The calling procedure in this case doesn't select the range. Instead it prints its address. That is for testing purposes. CellsForExport("$B:$C, $E:$E, G").Select will select the cells. You could also paste this range somewhere or manipulate it in any other way you can manipulate a range.
Note that you can omit the $ signs when specifying the columns. You also don't have to specify E:E to define a single column, but if someone does all that the macro will sort it out. Blank spaces don't matter, commas are of the essence.
Basically, Column is a range, not a string. This code will do the job.
Dim Rng As Range
With ActiveSheet
Set Rng = Application.Union(.Columns("B"), .Columns("C"), .Columns("E"))
End With
Rng.Select

Excel VBA, faster, cleaner way to find matching values/index match and return value from another column?

The code I've written below to replace some index match formulas in a sheet. It seems to work well enough, but I think the loop is a bit clumsy and may be prone to errors. Does anyone have any recommended improvements?
Sub match_SIC_code_sheet_loop()
'sic code needs to match value in column j or a in sic code sheet, '
'if not available = met10 works, but probably needs a bit more
'debugging to make it robust.
Dim ws As Integer
Dim lastrow As Long
Dim lastrow_sic As Long
Dim output_wb As Workbook
Dim SIC_sheet As Worksheet
Dim Demand_CAT As String
Dim sic_DMA As String
Dim i As Integer
Dim row As Integer
Dim WS_count As Long
Dim x As String
Dim y As String
Set output_wb = Workbooks("DMA_customers_SICTEST.xlsx") 'use thisworkbook instead
Set SIC_sheet = Workbooks("DMA_metered_tool_v12_SICTEST.xlsm").Sheets("SIC codes")
With SIC_sheet 'count the number of SIC codes to search through
lastrow_sic = .Range("j" & .Rows.Count).End(xlUp).row
End With
With output_wb 'count the no. of sheets in the generated customer workbook
WS_count = output_wb.Worksheets.Count
End With
With output_wb
For ws = 1 To WS_count 'loop through each sheet in the customer workbook
With output_wb.Sheets(ws)
y = output_wb.Sheets(ws).Name
lastrow = .Range("a" & .Rows.Count).End(xlUp).row ' number of rows in the
'current customer sheet
For i = 2 To lastrow 'data starts in row 2; sic code in column 9
sic_DMA = .Cells(i, 9).Text 'the lookup value
With SIC_sheet
'SIC codes start in row 2, if the sic code matches,
'the correct demand category is appointed, if the sic code does not
'match, then MET_10 is given as the default value.
For row = 2 To lastrow_sic
x = .Cells(row, 3).Text
If x = sic_DMA Then
Demand_CAT = .Cells(row, 10).Text
Exit For
Else
Demand_CAT = "MET_10"
End If
Next row
output_wb.Sheets(ws).Cells(i, 23).Value = Demand_CAT
End With
Next i
End With
Next ws
End With
output_wb.Save
End Sub
Thanks
For starters you could break that long procedure into a few smaller methods. For example you could have a ProcessSheet procedure into which you pass each sheet under :
For ws = 1 To WS_count 'loop through each sheet in the customer workbook
That would definitely help readability etc. If you're still not satisfied then continue breaking the loop into smaller logical procedures. Just don't go too crazy.
Apart from that some error checking and value validation would go a long way in a deeply nested loop. For example ensure that various calculated variables such as 'lastrow' are correct or within a valid threshold etc.
Finally instead of hardcoded values sprinkled through your long loop like magically camoflauged debug-from-hell-where's-waldo fairies; prefer instead a few meaningfully named Const variable alternatives i.e.
Private Const SIC_START_ROW = 2

Resources