I want to sort a column from smallest to largest. The column is like:
Day_Cluster
(0,5]
(10,15]
(5,10]
(15,20]
I want to sort from smallest to largest but it is not happening in MS Excel. How to achieve this?
Expected output:
(0,5]
(5,10]
(10,15]
(15,20]
A Special Sort
Manual
If your data is in column A, and you have data in column B then right-click in the column header of column B (selecting the whole column) and select Insert.
If your decimal separator is a period (dot) then use this formula in cell B1:
=VALUE(SUBSTITUTE(MID(A1,2,LEN(A1)-2),",","."))
and copy down as needed.
If your decimal separator is a comma then use this formula in cell B1:
=VALUE(MID(A1,2,LEN(A1)-2))
and copy down as needed.
Now sort your data by the B column ascending.
Delete column B or just clear the data in it.
Using VBA
Copy the code to a standard module, e.g. Module1.
The data is modified in place (no inserting, shifting...).
The decimal separator is irrelevant.
Option Explicit
Sub BubbleSortIntervalsASC()
Const ProcName As String = "BubbleSortIntervalsASC"
On Error GoTo ClearError
Const FirstCellAddress As String = "A1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the column range.
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCell.Column).End(xlUp).Row
Dim rCount As Long: rCount = lRow - fCell.Row + 1
If rCount < 2 Then Exit Sub
Dim srg As Range: Set srg = fCell.Resize(rCount)
' Write the values from the source (one-column) range to the source array.
Dim sData As Variant: sData = srg.Value
' Write the same values converted to numbers to the numbers array.
Dim nData As Variant: nData = ws.Evaluate("VALUE(SUBSTITUTE(MID(" _
& srg.Address & ",2,LEN(" & srg.Address & ")-2),"","","".""))")
Dim i As Long, j As Long
Dim sT As String, nT As Double
' Bubble sort the numbers array
' and do the same 'respective' shifting in the source array.
For i = 1 To rCount - 1
For j = i To rCount
If nData(i, 1) > nData(j, 1) Then
nT = nData(i, 1): nData(i, 1) = nData(j, 1): nData(j, 1) = nT
sT = sData(i, 1): sData(i, 1) = sData(j, 1): sData(j, 1) = sT
End If
Next j
Next i
' Write the sorted values from the source array to the source range.
srg.Value = sData
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Related
I'm a VBA noob. I need help working out this filter:
My data has ~50,000 rows and 100 columns. The column I want to filter has values like TL-98.263138472% BD-1.736861528%. I want to filter out all the values in VBA where TL>90%. I can think of a long way of doing it - where I create a loop, break down each cell, then look at TL, then the 4 numbers next to it. But it sounds like it would take forever. Wondering if there's a faster/easier way to do it? Also wondering, if it's even worth it. If it would take even more than 2 seconds, then I would rather not do it with VBA.
I have not coded it yet, wanted to see if anyone has better ideas than what I came up with.
Thanks in advance! Adding an example of my data below:
Pretty fast in my tests:
Sub tester()
Dim ws As Worksheet, t
Dim i As Long, rng As Range, rngFilt As Range, arr, arrFilt
' For i = 2 To 50000 'create some dummy data
' Cells(i, "A") = "TL-" & 50 + (Rnd() * 60) & "% BD-1.736861528%"
' Next i
' [B2:CV50000].value="blah" 'fill rest of table
t = Timer
Set ws = ActiveSheet
If ws.FilterMode Then ws.ShowAllData
Set rng = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row) 'range of values to filter
Set rngFilt = rng.Offset(0, 110) 'a range off to the right to filter on
arr = rng.Value
arrFilt = rngFilt.Value 'for holding filtering flags
arrFilt(1, 1) = "Filter" 'column header
For i = 2 To UBound(arr, 1)
arrFilt(i, 1) = IIf(FilterOut(arr(i, 1)), "Y", "N")
Next i
rngFilt.Value = arrFilt
rngFilt.AutoFilter field:=1, Criteria1:="N"
Debug.Print Timer - t
End Sub
'does this value need to be filtered out?
Function FilterOut(v) As Boolean
Dim pos As Long
pos = InStr(v, "TL-")
If pos > 0 Then
v = Mid(v, pos + 3)
pos = InStr(v, "%")
If pos > 0 Then
v = Left(v, pos - 1)
'Debug.Print v
If IsNumeric(v) Then FilterOut = v > 90
End If
End If
End Function
This ran in <0.3 sec for me, on a 50k row X 100 col dataset
Filter Via Table Helper Column and String Parse
It you want to look into non VBA solutions, You could use a helper column to decide it it's worth filtering out.
First we need to find "TL-" in the string, then find "%" After that:
MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3)
This will just return us that value sub string, regardless or position.
Now we need to convert it into a value... and I'm told that --( ) isn't the correct way to convert a string to a value... but i keep using it and it keeps working.
Anyway, finally we test if that is larger than 90 like:
=IF(--(MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3))>90,"Remove","Keep")
Here's my example:
And the final result.
And Filtered:
Copy Values (Efficiently!?)
The Code
Option Explicit
Sub CopyData()
Dim T As Double: T = Timer
' Read Data: Write the values from the source range to an array.
' Define constants.
Const SRC_NAME As String = "Sheet1"
Const SRC_COLUMN As Long = 44
Const CRIT_STRING_LEFT As String = "TL-"
Const CRIT_VALUE_GT As Double = 90
Const DST_NAME As String = "Sheet2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
' Write to the array (practically this line uses up all the time).
Dim Data(): Data = srg.Value ' assumes at least two cells in 'srg'
Debug.Print "Read Data: " & Format(Timer - T, "0.000s")
T = Timer
' Modify Data: Write the critical values to the top of the array.
Dim cLen As Long: cLen = Len(CRIT_STRING_LEFT)
Dim dr As Long: dr = 1 ' skip headers
Dim sr As Long, c As Long
Dim cPos As Long, cNum As Double, cString As String
For sr = 2 To srCount ' skip headers
cString = CStr(Data(sr, SRC_COLUMN))
cPos = InStr(1, cString, CRIT_STRING_LEFT, vbTextCompare)
If cPos > 0 Then
cString = Right(cString, Len(cString) - cPos - cLen + 1)
cString = Replace(cString, "%", "")
cNum = Val(cString) ' 'Val' doesn't work with "!,#,#,$,%,&,^"
If cNum > CRIT_VALUE_GT Then ' 'Evaluate' is too slow!
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
Next sr
Debug.Print "Modify Data: " & Format(Timer - T, "0.000s")
T = Timer
' Write Data: Write the values from the array to the destination range.
If dr = 0 Then Exit Sub ' no filtered values
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim drg As Range: Set drg = dws.Range("A1").Resize(dr, cCount)
' Write to the range (practically this line uses up all the time).
drg.Value = Data
' Clear below
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
Debug.Print "Write Data: " & Format(Timer - T, "0.000s")
MsgBox "Data copied.", vbInformation
End Sub
The Result (Time Passed)
On a sample of 50k rows by 100 columns of data with 26k matches, the code finished in under 5s:
Read Data: 1.336s
Modify Data: 0.277s
Write Data: 3.375s
There were no blank cells and each cell in the criteria column contained the criteria string with a percentage hence it should be faster on your data. Your feedback is expected.
Is there in VBA faster way to change row (or cell) color based on values without referring to cell
Referring to cell each time inside loop is very slow, that's why i am looking for faster method doing it in VBA.
Table:
Amount1
Amount2
100
50
20
200
...
...
If Amount1 is greater than Amount2, entire row(or cell) is red, vice versa entire row(or cell) is green.
Thank You!
It would have been helpful if you had clarified why you can't use CF as suggested, but if you really can't when looping it's best to refer to directly to cells as little as possible, especially changing values or formats. Try something like this:
Sub SampleValues()
Dim bGreater As Boolean
Dim rng As Range, rRow As Range
Set rng = ActiveSheet.Range("A1:B1000")
rng.Formula = "=RANDBETWEEN(1,1000)"
rng.Value = rng.Value
End Sub
Sub RedOrGreen()
Dim clr As Long, i as long
Dim rng As Range, rRow As Range
Dim arr As Variant
Const clrMore = vbGreen, clrLessEqual = vbRed
Dim t As Single
t = Timer
Set rng = Range("A1:B1000")
arr = rng.Value
For Each rRow In rng.Rows
i = i + 1
If arr(i, 2) > arr(i, 1) Then
clr = clrMore
Else
clr = clrLessEqual
End If
If rRow.Interior.Color <> clr Then
rRow.Interior.Color = clr
End If
Next
Debug.Print Timer - t
End Sub
Highlight Rows
Sub HighlightRows()
Dim t As Double: t = Timer
' Define constants (adjust).
Const PROC_TITLE As String = "Highlight Rows"
Const SMALL_COL As Long = 1
Const GREAT_COL As Long = 2
Dim RowColors(): RowColors = VBA.Array(vbGreen, vbRed)
' Reference the table range.
' Turn off screen updating.
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
' Validate rows and columns.
' Validate rows.
Dim rCount As Long: rCount = trg.Rows.Count
If rCount < 2 Then
MsgBox "No data or just headers in the range '" _
& trg.Address(0, 0) & "'.", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Validate columns.
Dim cCount As Long: cCount = trg.Columns.Count
Dim MaxCol As Long: MaxCol = Application.Max(SMALL_COL, GREAT_COL)
If cCount < GREAT_COL Then
MsgBox "Column " & MaxCol & " is greater than the number " _
& "of columns (" & cCount & ") in the range ('" _
& trg.Address(0, 0) & "').", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Reference and populate the helper columns.
' Insert two helper columns adjacent to the right of the table range.
trg.Offset(, cCount).Resize(, 2).Insert xlShiftToRight
' Remove this line if there is no data to the right.
' Reference the expanded table range (including the helper columns)...
Dim erg As Range: Set erg = trg.Resize(, cCount + 2) ' has headers
' ... and reference its data to be used with 'SpecialCells'.
Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
' Reference the helper columns.
Dim CompareCol As Long: CompareCol = cCount + 1 ' for the auto filter
Dim crg As Range: Set crg = erg.Columns(CompareCol)
Dim irg As Range: Set irg = erg.Columns(cCount + 2)
' Write an ascending integer sequence to the Integer column.
irg.Value = ws.Evaluate("ROW(1:" & rCount & ")")
' Write the values from the criteria columns to arrays.
Dim SmallData(): SmallData = erg.Columns(SMALL_COL).Value
Dim GreatData(): GreatData = erg.Columns(GREAT_COL).Value
' Define the Compare array.
Dim CompareData(): ReDim CompareData(1 To rCount, 1 To 1)
Dim SmallVal, GreatVal, r As Long
' Write the Compare results to the Compare array
' (1 for the 1st color and 2 for the 2nd), ...
For r = 2 To rCount ' skip headers
SmallVal = SmallData(r, 1)
GreatVal = GreatData(r, 1)
If IsNumeric(SmallVal) And IsNumeric(GreatVal) Then
Select Case SmallVal
Case Is < GreatVal: CompareData(r, 1) = 1
Case Is > GreatVal: CompareData(r, 1) = 2
End Select
End If
Next r
Erase SmallData
Erase GreatData
' ... write the results from the array to the Compare column...
crg.Value = CompareData
Erase CompareData
' ... and sort the range by it.
erg.Sort crg, xlAscending, , , , , , xlYes
' Highlight the rows.
edrg.Interior.Color = xlNone ' clear previous colors
Dim vedrg As Range
For r = 1 To 2
erg.AutoFilter CompareCol, CStr(r)
On Error Resume Next ' prevent error when no filtered rows
Set vedrg = edrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False ' turn off the auto filter!!!
If Not vedrg Is Nothing Then
Debug.Print vedrg.Address ' only two areas are being highlighted
vedrg.Interior.Color = RowColors(r - 1) ' 'RowColors' is zero-based
Set vedrg = Nothing ' reset for the next iteration
End If
Next r
' Clean up.
' Sort the range by the Integer column restoring initial order.
erg.Sort irg, xlAscending, , , , , , xlYes
' Delete the helper columns.
crg.Resize(, 2).Delete xlShiftToLeft
' If you have removed the Insert-line, replace this line with:
'crg.Resize(, 2).Clear
' Turn on screen updating to immediately see the changes
' (if the worksheet is active) before OK-ing the message box.
Application.ScreenUpdating = True
Debug.Print Format(Timer - t, "00.000000")
' Inform.
MsgBox "Rows highlighted.", vbInformation, PROC_TITLE
End Sub
In a sheet of my workbook I have range C8:C104 filled with values from another sheet of my workbook. These number of values can vary from 2 to 96 with no blank cells in between.
Before copying these values to a txt-file I need to auto fill blank cells in this column until the number of non blank cells in the range can be divided by 4.
Example:
C8:C12 contain data => no cells need to be auto filled
C8:C10 contain data => Cells C11 and C12 need to be filled with the text "x" (the rest of the cells in the range stay blank)
Normally Google is my best friend in situations like this, but unfortunately I could not find any Q&A similar to this. I got the part running to copy the cells and sending them as a txt.file by outlook mail, but have no clue how to get the auto fill part up and running yet.
Is there anyone who can help me get started, am not very experienced and a bit rusty with my VBA skills?
The following will pad the cells with x until there are a multiple of 4 cells populated:
Sub pad_to_mod_4()
Dim myrange As Range
Dim ws As Worksheet
padding = "x"
Set ws = ActiveSheet 'set this to your worksheet
Set myrange = ws.Range("C8:C104")
Do Until myrange.Cells.SpecialCells(xlCellTypeConstants).Count Mod 4 = 0
myrange(myrange.Count).End(xlUp).Offset(1, 0).Value = padding
Loop
End Sub
Return a Column in a String Conditionally
Adjust the values in the constants section.
Reference the worksheet more safely.
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Tests the 'StrFilledColumnRange' function.
' Calls: StrFilledColumnRange, TextString.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub StrFilledColumnRangeTEST()
' Define constants.
Const FilePath As String = "C:\Test\Test.txt"
Const crgAddress As String = "C8:C104"
Const FillString As String = "x"
Const ModNonBlank As Long = 4
Const HasHeader As Boolean = True
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the (one-column) range ('crg').
Dim crg As Range: Set crg = ws.Range(crgAddress)
' Using the function, return the required values in a string ('rString').
Dim rString As String
rString = StrFilledColumnRange(crg, FillString, ModNonBlank, True)
' Check if the string is empty.
If Len(rString) = 0 Then
MsgBox "The resulting string is empty.", vbExclamation
Exit Sub
End If
' Display the result.
Debug.Print rString
'MsgBox rString, vbInformation
' Write the string to a text file.
'TextString FilePath, rString
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: From a given one-column range, returns a string that...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrFilledColumnRange( _
ByVal ColumnRange As Range, _
ByVal FillString As String, _
Optional ByVal ModNonBlank As Long = 1, _
Optional ByVal HasHeader As Boolean = False) _
As String
Const ProcName As String = "StrFilledColumnRange"
On Error GoTo ClearError
' Reference the first cell ('fCell') of the range.
Dim fCell As Range: Set fCell = ColumnRange.Cells(1)
' Reference the column data range ('cdrg')(no headers).
Dim hrOffset As Long
If HasHeader Then hrOffset = 1
Dim cdrg As Range: Set cdrg = ColumnRange _
.Resize(ColumnRange.Rows.Count - hrOffset).Offset(hrOffset)
' Make sure that all rows and columns are visible, or the following
' use of the Find method will fail.
' Reference the bottom-most non-blank cell ('lCell')
' of the column data range ('xlValues' - non-blanks).
Dim lCell As Range: Set lCell = cdrg.Find("*", , xlValues, , , xlPrevious)
If lCell Is Nothing Then
MsgBox "No data in '" & cdrg.Address(0, 0) & "'.", vbCritical
Exit Function
End If
' Retrieve the current number of rows ('crCount') of the column data range.
Dim crCount As Long: crCount = lCell.Row - fCell.Row - hrOffset + 1
' Calculate the remainder ('Remainder'), the number of how many
' fill strings to be 'appended'.
Dim Remainder As Long: Remainder = crCount Mod ModNonBlank
If Remainder > 0 Then Remainder = ModNonBlank - Remainder
' Write the source number of rows to a variable ('srCount').
Dim srCount As Long: srCount = ColumnRange.Rows.Count
' Calculate the destination number of rows ('drCount')
' and correct 'Remainder'.
Dim drCount As Long: drCount = hrOffset + crCount + Remainder
If drCount > srCount Then
Remainder = Remainder + srCount - drCount
drCount = srCount
End If
' Declare a variable for the resulting string ('rString').
Dim rString As String
If drCount = 1 Then ' one cell only; unlikely yet theoretically possible
rString = ColumnRange.Value
Else ' multiple cells
' Reference the last (offsetted) cell.
Set lCell = lCell.Offset(Remainder)
' Reference the range ('crg').
Dim crg As Range: Set crg = ColumnRange.Worksheet.Range(fCell, lCell)
' Write the values from the range to a 2D one-based array ('cData').
Dim cData() As Variant: cData = crg.Value
' Write the fill string(s) to the array.
Dim dr As Long ' Current Destination Row
For dr = drCount To drCount - Remainder + 1 Step -1
cData(dr, 1) = FillString
Next dr
' Write the values from the array to the resulting string.
rString = cData(1, 1)
For dr = 2 To drCount
rString = rString & vbLf & cData(dr, 1)
Next dr
End If
' Return the string as the result of the function.
StrFilledColumnRange = rString
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes a string to a file.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub TextString( _
ByVal FilePath As String, _
ByVal WriteString As String)
Const ProcName As String = "TextString"
On Error GoTo ClearError
Dim TextFile As Long: TextFile = FreeFile
Open FilePath For Output Access Write As #TextFile
Print #TextFile, WriteString
Close TextFile
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
I want to add the formulae with a pattern as below across the rows. Is there an easy way through VBA?
Cell AB16 = SUM(AC9:AC13)/SUM(AB9:AB13)
Cell AC16 = SUM(AD8:AD12)/SUM(AC8:AC12)
Cell AD16 = SUM(AE7:AE11)/SUM(AD7:AD11)
Cell AE16 = SUM(AF6:AF10)/SUM(AE6:AE10)
Cell AF16 = SUM(AG5:AG9)/SUM(AF5:AF9)
....
And so on.
I tried extracting the formula using .formula function and trying to create individual loops to absorb the increasing pattern in alphabets and decreasing pattern in numbers. Here the issue I am facing is till A to z I can increment the loop from ascii 65 to 90. Beyond z, it gets tedious as I need to jump to AA.
Is there a better way to achieve the above formula fill across rows via VBA but I want the formula format to be as above Sum(xxx:xxx)/sum(yyy:yyy)? The constraint is, I can not have hard coded numbers ran through macro in these cells. Also, can't afford to have offset formula in these cells too. These cells are capable of taking in only Sum(xxx:xxx)/sum(yyy:yyy) format.
As usual with Excel, you don't need to concern yourself with alphabets. Rows and columns are actually numbered, the letters only appear in the end and only for your convenience. You are free to ignore them and speak in R1C1 which is the Excel's native language:
Dim target As Range
Set target = Range("AB16:AF16")
Dim start_offset As Long
start_offset = 2
Dim c As Range
For Each c In target
c.FormulaR1C1 = "=SUM(R[-" & (start_offset + 5) & "]C[1]:R[-" & (start_offset + 1) & "]C[1])/SUM(R[-" & (start_offset + 5) & "]C:R[-" & (start_offset + 1) & "]C)"
start_offset = start_offset + 1
Next
Write a Formula (VBA)
Option Explicit
Sub WriteSumsDivision()
Const rAddress As String = "AB16:AF16"
Const rOffset As Long = 22
Const cSize As Long = 5
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim rrg As Range: Set rrg = ws.Range(rAddress)
Dim fCol As Long: fCol = rrg.Cells(1).Column
Dim cCount As Long: cCount = rrg.Columns.Count
Dim cOffset As Long: cOffset = rOffset - fCol
Dim MaxOffset As Long: MaxOffset = cSize - rOffset + 1
Dim rCell As Range
Dim rArr As Variant: ReDim rArr(1 To cCount)
Dim cFormula As String
Dim c As Long
For Each rCell In rrg.Cells
c = c + 1
cOffset = cOffset - 1
If cOffset > MaxOffset Then
cFormula = "=SUM(" & rCell.Offset(cOffset, 1) _
.Resize(cSize).Address(0, 0) & ")/SUM(" _
& rCell.Offset(cOffset).Resize(cSize).Address(0, 0) & ")"
rArr(c) = cFormula
Else
Debug.Print "Limit hit."
Exit For
End If
Next rCell
rrg.Formula = rArr
End Sub
I need to sum two columns (B and C) in a dataset. The number of rows with data will vary between 1 and 17. I need to add the sums two rows beneath the last row of data (end result example in image 1).
My code worked beautifully for one dataset, but I am getting an error
Run-time error'6': Overflow
for a different dataset. What am I doing wrong?
'Units total
Windows("Final_Files.xlsb").Activate
Sheets("Revenue Summary").Select
lastrow = Worksheets("Revenue Summary").Cells(Rows.Count, 2).End(xlUp).Row
Dim a As Integer
a = 10000
For i = lastrow To 2 Step by - 1
a = a + Worksheets("Revenue Summary").Cells(i, 2).Value
Next
Worksheets("Revenue Summary").Cells(lastrow + 2, 2).Value = a
Correct End Result
You can try below sub-
Sub SumBC()
Dim sh As Worksheet
Dim lRowB As Long, lRowC As Long
Dim bSum As Double, cSum As Double
Windows("Final_Files.xlsb").Activate
Set sh = Worksheets("Revenue Summary")
lRowB = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
lRowC = sh.Cells(sh.Rows.Count, 3).End(xlUp).Row
bSum = WorksheetFunction.Sum(sh.Range("B2:B" & lRowB))
cSum = WorksheetFunction.Sum(sh.Range("C2:C" & lRowC))
sh.Cells(lRowB + 2, 2) = bSum
sh.Cells(lRowC + 2, 3) = cSum
sh.Activate
Set sh = Nothing
End Sub
Remember: If you want to run same sub multiple time then you need clear totals otherwise it will add totals again again below of last totals.
Your code is perfect but there is only one error. You have initialized variable 'a' with 10000. Change it to 0.
a = 0
then your code will be perfect.
Add Totals to Multiple Columns
If you're not OP: It is easy to test the code. Open a new workbook and insert a module. Copy the code into the module. Uncomment the Sheet1 line, and outcomment the Revenue Summary line. In worksheet Sheet1 add some numbers in columns 2 and 3 and your ready.
Run only the insertTotals procedure. The calculateSumOfRange is called when needed.
Play with the constants in insertTotals and change the values in the columns. Add text, error values, booleans to see how the code doesn't break.
The issue with Application.Sum or WorksheetFunction.Sum is that it fails when there are error values in the range. That's what the calculateSumOfRange is preventing. If there is an error value, the loop approach is used. If not, then Application.Sum is the result.
You can use the calculateSumOfRange in Excel as a UDF. Just don't include the cell where the formula is and you're OK, e.g. =calculateSumOfRange(A1:B10).
The Code
Option Explicit
Sub insertTotals()
Const FirstRow As Long = 2 ' First Row of Data
Const LastRowCol As Long = 2 ' The column where the Last Row is calculated.
Const TotalsOffset As Long = 2 ' 2 means: 'data - one empty row - totals'
Dim Cols As Variant
Cols = Array(2, 3) ' add more
'With ThisWorkbook.Worksheets("Sheet1")
With Workbooks("Final_Files.xlsb").Worksheets("Revenue Summary")
' Define Last Row ('LastRow') in Last Row Column ('LastRowCol').
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, LastRowCol).End(xlUp).Row
' Define Last Row Column Range ('rng').
Dim rng As Range
Set rng = .Range(.Cells(FirstRow, LastRowCol), _
.Cells(LastRow, LastRowCol))
Dim j As Long
' Validate Columns Array ('Cols').
If LBound(Cols) <= UBound(Cols) Then
' Iterate columns in Columns Array.
For j = LBound(Cols) To UBound(Cols)
' Use 'Offset' to define the current Column Range and write
' its calculated total below it.
.Cells(LastRow + TotalsOffset, Cols(j)).Value = _
calculateSumOfRange(rng.Offset(, Cols(j) - LastRowCol))
Next j
End If
End With
End Sub
Function calculateSumOfRange(SourceRange As Range) _
As Double
' Initialize error handling.
Const ProcName As String = "calculateSumOfRange"
On Error GoTo clearError ' Turn on error trapping.
' Validate Source Range.
If SourceRange Is Nothing Then
GoTo NoRange
End If
' Calculate Sum of Range.
Dim CurrentValue As Variant
CurrentValue = Application.Sum(SourceRange)
Dim Result As Double
If Not IsError(CurrentValue) Then
Result = CurrentValue
Else
Dim Data As Variant
If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
Data = SourceRange.Value
Else
ReDim Data(1, 1)
Data(1, 1) = SourceRange.Value
End If
Dim i As Long
Dim j As Long
For i = 1 To UBound(Data, 1)
For j = 1 To UBound(Data, 2)
CurrentValue = Data(i, j)
If IsNumeric(CurrentValue) And _
Not VarType(CurrentValue) = vbBoolean Then
Result = Result + CurrentValue
End If
Next j
Next i
End If
' Write result and exit.
calculateSumOfRange = Result
GoTo ProcExit
' Labels
NoRange:
Debug.Print "'" & ProcName & "': No range (Nothing)."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
ProcExit:
End Function
The following code summs up all the rows under "B2" and "C2". Adapt it to your needs.
' Keep a reference to the worksheet
Dim ws as Worksheet
Set ws = Worksheets("Revenue Summary")
' This is how many rows there are.
Dim rowCount as Long
rowCount = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row-1
' This is the summation operation over each column
Dim b as Double, c as Double
b = WorksheerFunction.Sum(ws.Range("B2").Resize(rowCount,1))
c = WorksheerFunction.Sum(ws.Range("C2").Resize(rowCount,1))
' This writes the sum two cells under the last row.
ws.Range("B2").Cells(rowCount+2,1).Value = b
ws.Range("C2").Cells(rowCount+2,1).Value = c