Specify an Excel range across sheets in VBA - vba

In VBA, why does the following fail?
Dim rng as Range
rng = Range("Sheet1:Sheet3!A1")
It throws an HRESULT exception. Is there another way to construct this range in VBA? Note that you can enter a worksheet function like =SUM(Sheet1:Sheet3!A1) and it works fine.

A Range object is limited to only one worksheet. After all, it can have only a single parent.
The =SUM() function can operate on a group of ranges. (this is true for many worksheet functions)
EDIT#1
I have been searching for a solution since Janauary:
UDF Syntax
.
I have been using an array of ranges. Not a very good solution.

Just developing Gary's answer (if you're going to accept an answer, accept his :):
Using Range variable:
Sub SumTest1()
Dim rSheet1 As Range
Dim rSheet2 As Range
Dim rSheet3 As Range
Dim dSum As Double
With ThisWorkbook
Set rSheet1 = .Sheets("Sheet1").Range("A1")
Set rSheet2 = .Sheets("Sheet2").Range("A1")
Set rSheet3 = .Sheets("Sheet3").Range("A1")
End With
dSum = WorksheetFunction.Sum(rSheet1, rSheet2, rSheet3)
Debug.Print CStr(dSum)
End Sub
Using Variant variable:
Sub SumTest2()
Dim vArray As Variant
Dim dSum As Double
With ThisWorkbook
vArray = Array(.Sheets("Sheet1").Range("A1"), .Sheets("Sheet2").Range("A1"), .Sheets("Sheet3").Range("A1"))
End With
dSum = WorksheetFunction.Sum(vArray)
Debug.Print CStr(dSum)
End Sub
Using no variable:
Sub SumTest3()
Dim dSum As Double
With ThisWorkbook
dSum = WorksheetFunction.Sum(Array(.Sheets("Sheet1").Range("A1"), .Sheets("Sheet2").Range("A1"), .Sheets("Sheet3").Range("A1")))
End With
Debug.Print CStr(dSum)
End Sub

Here's a set of UDF functions that accomplish essentially the same thing. The only caveat is that the reference to the 3D range is a string i.e. "Jan:Dec!A1" as opposed to straight up Jan:Dec!A1
'Adapted from https://web-beta.archive.org/web/20060313132405/http://www.j-walk.com/ss/excel/eee/eee003.txt by Andre Terra
Function CountIf3D(Range3D As String, Criteria As String, _
Optional Count_Range As Variant) As Variant
Dim sTestRange As String
Dim sCountRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Count As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
CountIf3D = CVErr(xlErrRef)
End If
If IsMissing(Count_Range) Then
sCountRange = sTestRange
Else
sCountRange = Count_Range.Address
End If
Count = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Count = Count + Application.WorksheetFunction.CountIf(.Range _
(sTestRange), Criteria)
End With
Next n
CountIf3D = Count
End Function 'CountIf3D
Function SumIf3D(Range3D As String, Criteria As String, _
Optional Sum_Range As Variant) As Variant
Dim sTestRange As String
Dim sSumRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Sum As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
SumIf3D = CVErr(xlErrRef)
End If
If IsMissing(Sum_Range) Then
sSumRange = sTestRange
Else
sSumRange = Sum_Range.Address
End If
Sum = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Sum = Sum + Application.WorksheetFunction.SumIf(.Range _
(sTestRange), Criteria, .Range(sSumRange))
End With
Next n
SumIf3D = Sum
End Function 'SumIf3D
Function AverageIf3D(Range3D As String, Criteria As String, _
Optional Average_Range As Variant) As Variant
Dim sTestRange As String
Dim sSumRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Sum As Double
Dim Count As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
AverageIf3D = CVErr(xlErrRef)
End If
If IsMissing(Average_Range) Then
sSumRange = sTestRange
Else
sSumRange = Average_Range.Address
End If
Sum = 0
Count = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Sum = Sum + Application.WorksheetFunction.SumIf(.Range(sTestRange), Criteria, .Range(sSumRange))
Count = Count + Application.WorksheetFunction.CountIf(.Range(sTestRange), Criteria)
End With
Next n
AverageIf3D = Sum / Count
End Function 'SumIf3D
Function Parse3DRange(sBook As String, SheetsAndRange _
As String, FirstSheet As Integer, LastSheet As Integer, _
sRange As String) As Boolean
Dim sTemp As String
Dim i As Integer
Dim Sheet1 As String
Dim Sheet2 As String
Parse3DRange = False
On Error GoTo Parse3DRangeError
sTemp = SheetsAndRange
i = InStr(sTemp, "!")
If i = 0 Then Exit Function
'next line will generate an error if range is invalid
'if it's OK, it will be converted to absolute form
sRange = Range(Mid$(sTemp, i + 1)).Address
sTemp = Left$(sTemp, i - 1)
i = InStr(sTemp, ":")
Sheet2 = Trim(Mid$(sTemp, i + 1))
If i > 0 Then
Sheet1 = Trim(Left$(sTemp, i - 1))
Else
Sheet1 = Sheet2
End If
'next lines will generate errors if sheet names are invalid
With Workbooks(sBook)
FirstSheet = .Worksheets(Sheet1).Index
LastSheet = .Worksheets(Sheet2).Index
'swap if out of order
If FirstSheet > LastSheet Then
i = FirstSheet
FirstSheet = LastSheet
LastSheet = i
End If
i = .Worksheets.Count
If FirstSheet >= 1 And LastSheet <= i Then
Parse3DRange = True
End If
End With
Parse3DRangeError:
On Error GoTo 0
Exit Function
End Function 'Parse3DRange

Untested, but try this
Dim rng as string
rng = "Sheet1:Sheet3!A1"
worksheet("Sheet1").range("B1").formula = "=SUM(" & rng & ")"

Related

Round Numbers In Table Column Word VBA

Trying to only round the numbers in column 4 but this macro code isn't working properly. Maybe there is another way to word it.
It is using a selection for the range but I think there has to be another way of putting this.
Thank you.
Sub RoundNumbersInColumn()
Dim rowMax As Long
Dim rowStart As Long
Dim colNo As Long
Dim aCell As Cell
Dim aTable As Table
Dim tabPos As Single
Dim k As Long
Dim aValue As Single
Dim formatStr As String
Dim s As String
' set format to number of decimal places to round to
formatStr = "#0.0000"
Set aTable = Selection.Tables(1)
rowMax = aTable.Rows.Count
Set aCell = Selection.Cells(1)
rowStart = aCell.RowIndex
colNo = aCell.ColumnIndex
tabPos = -1
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.Item(1).Alignment = wdAlignTabDecimal Then _
tabPos = aCell.Range.ParagraphFormat.TabStops.Item(1).Position
End If
For k = rowStart To rowMax
Set aCell = aTable.Cell(Row:=k, Column:=4)
s = aCell.Range.Text
s = Left(s, Len(s) - 1)
If IsNumeric(s) Then
aValue = Val(s)
With aCell.Range.ParagraphFormat.TabStops
.ClearAll
.Add Position:=tabPos, Alignment:=wdAlignParagraphCenter
End With
aCell.Range.Text = Format(Str(aValue), formatStr)
End If
Next k
End Sub
Remove the underline after Then in line 26. Then add an End If to close the first If statement. Like so:
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.item(1).Alignment = wdAlignTabDecimal Then
tabPos = aCell.Range.ParagraphFormat.TabStops.item(1).Position
End If
End If

Create VBA function based on user-defined function

Thanks to all friends who helped me on my question how to calculate specific cells in excel
Now, I need help to code that excel function in VBA
The function is : =SUM(IFERROR(VALUE(IF(LEN(H27:Q27)=4,IF(ISNUMBER(SEARCH("b",LEFT(H27:Q27,2))),RIGHT(H27:Q27,1),LEFT(H27:Q27,1)),H27:Q27)),0))
Thanks in advance
Here you go:
Public Function GetTotal(rng As Range) As Long
Dim tot As Long
Dim celString As String
Dim t1String As String, t2String As String
For Each cel In rng
If IsNumeric(cel) Then
tot = tot + cel.Value
ElseIf Len(cel.Value) = 4 Then
celString = cel.Value
t1String = Left(celString, 2)
If InStr(1, t1String, "b") = 0 Then
t2String = Left(celString, 1)
Else
t2String = Right(celString, 1)
End If
tot = tot + t2String
End If
Debug.Print tot
Next
GetTotal = tot
End Function
You have to give range as input.
See the image below:
I think this function implements the formula. It's very difficult to test without your original set of data in the cells. Note the function is called from the Foo sub-routine below - so you can pass in a variable range to the function. Hope that helps.
Function DoIt(rng As Range)
' VBA implementation for
'=SUM(IFERROR(VALUE(IF(LEN(H27:Q27)=4,IF(ISNUMBER(SEARCH("b",LEFT(H27:Q27,2))),RIGHT(H27:Q27,1),LEFT(H27:Q27,1)),H27:Q27)),0))
Dim dblResult As Double
Dim rngCell As Range
Dim intLength As Integer
Dim strFragment1 As String
Dim strFragment2 As String
Dim intPos As Integer
'set result
dblResult = 0
'loop for the array formula
For Each rngCell In rngTarget
'check value length = 4
intLength = Len(rngCell.Value)
If intLength = 4 Then
'get bit of string and check for 'b' in string
strFragment1 = Left(rngCell.Value, 2)
'search for location of b in cell - use InStr for SEARCH
intPos = InStr(1, strFragment, "b", vbBinaryCompare)
If intPos <> 0 Then
'b in fragment
strFragment2 = Right(rngCell.Value, 1)
Else
'b not in fragment
strFragment2 = Left(rngCell.Value, 1)
End If
'2nd fragment should be a number? use IsNumeric for ISNUMBER and Val for VALUE
If IsNumeric(strFragment2) Then
dblResult = dblResult + Val(strResult)
End If
Else
'cell value length <> 4
'add cell value to result if is numeric - use IsNumeric for ISNUMBER and Val for VALUE
If IsNumeric(rngCell.Value) Then
dblResult = dblResult + Val(rngCell.Value)
End If
End If
'next cell
Next rngCell
'return sum
DoIt = dblResult
End Function
Sub Foo()
Dim rngTarget As Range
Set rng = Sheet1.Range("H27:Q27")
Debug.Print DoIt(rng)
End Sub

VBA Index/Match with multiple criteria (unique value & date)

I have a spreadsheet that has values for more than one month, so I am trying to first find the value based on a value in the wsRevFile worksheet and then ensure that this is the value from last month. When I use the following code, I get a "invalid number of arguments" error.
Sub RevLookup(wsMvFile As Worksheet, wsRevOld As Worksheet, wsNewRev As Worksheet, _
rowCount As Integer, workCol As String, _
srcCol1 As Integer, srcCol2 As Integer)
Dim vrw As Variant, i As Long
For i = 2 To rowCount
vrw = Application.Match(wsRevFile.Range("A" & i), wsNewRev.Columns(2), Format(DateSerial(Year(Date), Month(Date), 0), "mm/dd/yyyy"), wsNewRev.Columns(1), 0)
If IsError(vrw) Then
vrw = Application.Match(wsRevFile.Range("A" & i), wsRevOld.Columns(1), 0)
If Not IsError(vrw) Then _
wsRevFile.Range(workCol & i) = Application.Index(wsRevOld.Columns(srcCol1), vrw)
Else
wsRevFile.Range(workCol & i) = Application.Index(wsNewRev.Columns(srcCol2), vrw, 1)
End If
Next i
End Sub
I am assuming this has to do with the way I assigned the Application Match function, because the formula without this part works for other columns. Any ideas on how I could get this to work?
Thanks for your help!
Try ajusting the variables of the following procedure, as I didn't figure out your input and output data:
Sub Main()
Dim SearchValue As Variant
Dim SearchColumn As Range
Dim ReturnColumn As Range
Dim ResultRows As Collection
Dim LastDate As Variant 'Date?
Dim iRow As Variant
SearchValue = 10 '<-- change to suit
Set SearchColumn = wsNewRev.Range("B1:B10")
Set ReturnColumn = wsNewRev.Range("C1:C10") '<-- change to suit
Set ResultRows = GetLoopRows(SearchColumn, SearchValue)
For Each iRow In ResultRows
If LastDate < ReturnColumn(iRow) Then
LastDate = ReturnColumn(iRow)
End If
Next iRow
Debug.Print LastDate
End Sub
Function GetLoopRows(ParamArray pParameters() As Variant) As Collection
'Obtém limites de laços com levando em conta condições
'[vetor1], [valor1], [vetor2], [valor2], ...
Dim iCondition As Long
Dim i As Variant
Dim iRow As Variant
Dim Result As Collection
Dim NumConditions As Long
Dim SearchCollection As Collection
Dim ArraysCollection As Collection
Dim iArray As Variant
NumConditions = (UBound(pParameters) - LBound(pParameters) + 1) / 2
Set ArraysCollection = New Collection
Set SearchCollection = New Collection
For i = LBound(pParameters) To UBound(pParameters) Step 2
ArraysCollection.Add pParameters(i + 0).Value2
SearchCollection.Add pParameters(i + 1)
Next i
Set Result = New Collection
For iRow = LBound(ArraysCollection(1)) To UBound(ArraysCollection(1))
For iCondition = 1 To NumConditions
If ArraysCollection(iCondition)(iRow, 1) <> SearchCollection(iCondition) Then GoTo Continue
Next iCondition
Result.Add CLng(iRow)
Continue:
Next iRow
Quit:
Set GetLoopRows = Result
End Function

Index/Match while looping through rows and columns

I have written the following code, which I was hoping to use to look up values from columns 21 through to the last row in another sheet and return them to this sheet based on a value in column A in this sheet and column B in the other sheet.
When I use the code below I get an worksheet error. Could you please tell me why?
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
wbMVRVFile.Worksheets.Add().Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set wsMvFile = wbMVRVFile.ActiveSheet
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For wsColumn = 21 To lastColumn
For i = 2 To y
wsMvFile.Columns(wsColumn).Cells(i) = Application.Index(wsMvOld.Range(wsColumn), Application.Match(wsMvFile.Range("A" & i), wsMvOld.Range("B:B"), 0))
Next i
Next wsColumn
End Sub
Thanks for your help!
This untested, but it replaces the worksheet function to vba find method.
Private Sub Worksheet_Activate()
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
Set wsMvFile = wbMVRVFile.Worksheets.Add()
wsMvFile.Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For i = 2 To y
Dim rng As Range
Set rng = sMvOld.Range("B:B").Find(wsMvFile.Range("A" & i))
For wsColumn = 21 To lastColumn
If Not rng Is Nothing Then
wsMvFile.Columns(wsColumn).Cells(i).Value = wsMvOld.Cells(rng.Row, wsColumn)
Else
wsMvFile.Columns(wsColumn).Cells(i).Value = 0
End If
Next wsColumn
Next i
End Sub

Find last cell with values using indexes

I try to find the last cell in a column that contains values. I know I can use something like:
Dim findme As Range = excel.Range("A1:A" & lastrow.row)
but I am looking for a way not to use this column-character format. Something like this VBA format
Dim rng as range
with myWorksheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
rng = .Range(.Cells(1,1), .Cells(LastRow, 1))
end with
I created an helper class to solve this problem:
Imports Excel = Microsoft.Office.Interop.Excel
Public Class FindLastCellByIndex
Private Shared Function getStringRangeFormat(ByVal colNumber As Long, ByVal rowNumber As Long) As String
If colNumber > 0 AndAlso colNumber < 27 Then
Dim c As Char
c = Convert.ToChar(colNumber + 64)
Return (c & rowNumber & ":" & c).ToString
Else
Return ""
End If
End Function
Public Shared Function getSearchRange(ByRef _sheet As Excel.Worksheet, ByVal Col As Long, ByVal startRow As Long) As Excel.Range
Dim strColCharSpez As String = getStringRangeFormat(Col, startRow)
'Build String
Dim rng As Excel.Range = DirectCast(_sheet.Cells(_sheet.Rows.Count, startRow), Excel.Range)
Dim t As Long
t = rng.End(Excel.XlDirection.xlUp).Row
Return _sheet.Range(strColCharSpez & t)
End Function
End Class
This is the way to use it:
Dim rng As Excel.Range = FindLastCellByIndex.getSearchRange(_sheet, 3, 3)
Now you get the Range: Range(Cells(3,3), Cells(LastRow, 3) as an object.