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
Related
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
I need to do it for more than 1000 cells, to read the particular data and to put under respective cells using Excel VBA.
Example:
Name Age No. .. .
abc 14 123454 ------>this from single cell
Which contains like Name: abc,Age: 14, No: 123454
This should be a good start :
Sub Split_N_Copy()
Dim InFo()
Dim InfSplit() As String
InFo = ActiveSheet.Cells.UsedRange.Value2
Sheets.Add after:=Sheets(Sheets.Count)
For i = LBound(InFo, 1) To UBound(InFo, 1)
'Here I put InFo(i,1), "1" if we take the first column
InfSplit = Split(InFo(i,1), ",")
For k = LBound(InfSplit) To UBound(InfSplit)
Sheets(Sheets.Count).Cells(i + 1, k + 1) = InfSplit(k)
Next k
Next i
End Sub
I write a function based on , for separator sign and : for equal sign, that search a range of data that first row contains headers:
Function UpdateSheet(allData As String, inRange As Range)
Dim strData() As String
Dim i As Long, lastRow As Long
Dim columnName As String, value As String
Dim cell As Range
'You need to change this to finding last row like this answer:
'http://stackoverflow.com/a/15375099/4519059
lastRow = 2
strData = Split(allData, ",")
For i = LBound(strData) To UBound(strData)
columnName = Trim(Left(strData(i), InStr(1, strData(i), ":") - 1))
value = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
For Each cell In inRange
If cell.Cells(1, 1).Rows(1).Row = 1 Then
If cell.Cells(1, 1).value Like "*" & columnName & "*" Then
inRange.Worksheet.Cells(lastRow, cell.Columns(1).Column).value = value
End If
End If
Next
Next
End Function
Now you can use that function like this:
Sub update()
Call UpdateSheet("Name: abc,Age: 14, No: 123454", Sheets(1).UsedRange)
End Sub
Private Sub CommandButton1_Click()
lastRow = Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row
Dim i As Integer
i = 2
For i = 2 To lastRow
Dim GetData As String
GetData = Sheet1.Cells(i, 7)
Call UpdateSheet(GetData, Sheets(1).UsedRange, i)
Next
End Sub
Function UpdateSheet(allData As String, inRange As Range, rowno As Integer)
Dim strData() As String
Dim i As Long, lastRow As Long
Dim columnName As String, value As String
Dim cell As Range
strData = Split(allData, ",")
For i = LBound(strData) To UBound(strData)
Value1 = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
If Value1 <> "" Then
columnName = Trim(Left(strData(i), InStr(1, strData(i), ":") - 1))
value = Trim(Mid(strData(i), InStr(1, strData(i), ":") + 1))
For Each cell In inRange
If cell.Cells(1, 1).Rows(1).Row = 1 Then
If cell.Cells(1, 1).value Like "*" & columnName & "*" Then
inRange.Worksheet.Cells(rowno, cell.Columns(1).Column).value = value
End If
End If
Next
End If
Next
End Function
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 & ")"
I am looking for a method to compare a list of cell values to a certain reference value. If I would only need to compare the values I'd know how to achieve that. But here is the kicker: How can I look for a partial match? e.g.: the reference value should be "good". If the value of those cells would be "good" as well it should be considered a match. If the cell value is "Mr. goodcat" it should also be considered a match. My best guess would be to reference the original value to a string variable and put in some "*" if that would be possible.
Since I am not able to post some code, I don't need you to give me the whole answer, but a point in the right direction would be very nice. Thanks in advance guys.
edit: I have put in my final code. A short explaination: It loops through values in Sheet2 and compares them to values in column J in Sheet 1. If it finds a (partial) match, it highlights the cell.
Sub CompareValues()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws1Lrow As Long
Dim ws2Lrow As Long
Dim i As Integer
Dim x As Integer
Dim k As Integer
Dim reference As String
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
ws1Lrow = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
ws2Lrow = Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To ws2Lrow Step 1
ws2.Select
Cells(i, 1).Select
reference = ActiveCell
ws1.Select
For x = 2 To ws1Lrow
k = InStr(1, Cells(x, 10), reference, vbTextCompare)
If k > 0 Then
Cells(x, 10).Interior.ColorIndex = 6
End If
Next x
Next i
End Sub
How about this?
Dim I As Integer
I = InStr(1, "Mr. goodcat", "good", vbTextCompare)
If I > 0 Then
' Match
Else
' No Match
End
Here's more advanced function which allows wildcards in the middle:
Function PatternMatch(ByVal SearchIn As String, ByVal Pattern As String) As Boolean
If Len(SearchIn) = 0 Or Len(Pattern) = 0 Then
PatternMatch = False
Exit Function
End If
Dim Position As Integer
Dim MatchFirst As Boolean
Dim MatchLast As Boolean
Dim Chunks() As String
MatchFirst = (Left(Pattern, 1) <> "*")
MatchLast = (Right(Pattern, 1) <> "*")
Chunks = Split(Pattern, "*")
LastChunkIndex = UBound(Chunks)
If MatchFirst Then
If Not (Left(SearchIn, Len(Chunks(0))) = Chunks(0)) Then
PatternMatch = False
Exit Function
End If
End If
If MatchLast Then
If Not (Right(SearchIn, Len(Chunks(LastChunkIndex))) = Chunks(LastChunkIndex)) Then
PatternMatch = False
Exit Function
End If
End If
Position = 1
For Each Chunk In Chunks
ChunkLength = Len(Chunk)
If ChunkLength > 0 Then
NextPosition = InStr(Position, SearchIn, Chunk, vbTextCompare)
If NextPosition > 0 And NextPosition >= Position Then
Position = NextPosition + ChunkLength
Else
PatternMatch = False
Exit Function
End If
End If
Next Chunk
PatternMatch = True
End Function
Function ChangeColVal(ByVal Rng As Range, ByVal ValueToChange As Integer)
Dim Cell1, Cell2 As String
Dim PosOfColon, TotalCell, Sum As Integer
PosOfColon = InStr(1, Rng.Address, ":")
Cell1 = Left(Rng.Address, PosOfColon - 1)
Cell2 = Right(Rng.Address, Len(Rng.Address) - PosOfColon)
If Left(Cell1, 2) = Left(Cell2, 2) Then
TotalCell = Rng.Count
For i = 0 To TotalCell
If IsNumeric(Range(Cell1).Offset(i, 0).Value) = False Then
GoTo 112:
End If
Cell2 = Range(Cell1).Offset(i, 0).Address
Sum = Range(Cell2).Cells.Value + ValueToChange
On Error GoTo 111
'Here getting error...
Range(Cell2).Value = Sum
GoTo 112
111:
MsgBox (Err.Number & ":" & Err.Description)
112:
Next i
Else
MsgBox ("Select Column only...")
End If
End Function
I wants to increase or decrease cell value of selected range.
I am getting error in line Range(Cell2).Value = Sum
Edit
thanx for reply, in line Range(Cell2).Value = Sum, Cell2 is pointing to cell address like $E$6.
If there is any option other than that pls let me know
ok Mihir. You cannot use a UDF (User Defined Function) to modify other cells then the one the formula is used in. However, there is a workaround it by calling your function from a sub. I will show you how to do it.
Open a new workbook and make your spreadsheet look like the picture below.
Fill in some random numbers in column A of Sheet1
Then open VBE and create a new module ( Project Explorer > Insert > Module ) and paste the code from below
Option Explicit
Sub ChangeColumnValue()
Dim rng As Range
Set rng = Selection
Dim inp As String
inp = InputBox("Value to change:")
Call ChangeColVal(rng, CLng(inp))
End Sub
Private Function ChangeColVal(ByRef rng As Range, ByVal ValueToChange As Long)
Dim Cell1, Cell2 As String
Dim PosOfColon, TotalCell, Sum As Long
PosOfColon = InStr(1, rng.Address, ":")
Cell1 = Left(rng.Address, PosOfColon - 1)
Cell2 = Right(rng.Address, Len(rng.Address) - PosOfColon)
If Left(Cell1, 2) = Left(Cell2, 2) Then
TotalCell = rng.Count
Dim i&
For i = 0 To TotalCell - 1
If Not IsNumeric(Range(Cell1).Offset(i, 0).Value) Then
GoTo 112:
End If
Cell2 = Range(Cell1).Offset(i, 0).Address
Sum = Range(Cell2).Cells.Value + ValueToChange
On Error GoTo 111
Range(Cell2).Value = Sum
GoTo 112
111:
MsgBox (Err.Number & ":" & Err.Description)
112:
Next i
Else
MsgBox ("Select Column only...")
End If
End Function
Then, go back to your spreadsheet and select your range with your mouse like this:
Ok, now hit ALT + F8 to View Macros and run the ChangeColumnValue macro.
You will be prompt for a Value to Change and all cells within selected range will be Increased/Decreased by that Value.
and your final result if you type 5 in the prompt box will look like this
Good luck!
finally here is the solution.
Sub ChangeRowValues()
Dim rng As Range
Dim R As Range
Dim ValueToChange As Long
Dim Cell1, Cell2 As String
Dim PosOfColon, TotalCell, Sums, i As Integer
Set rng = Selection
ValueToChange = Val(InputBox("Enter Number to Change:", "Enter Number...", 0))
PosOfColon = InStr(1, rng.Address, ":")
Cell1 = Left(rng.Address, PosOfColon - 1)
Cell2 = Right(rng.Address, Len(rng.Address) - PosOfColon)
If UCase(Left(Cell1, 1)) = UCase(Left(Cell2, 1)) Then
TotalCell = rng.Count
For i = 0 To TotalCell - 1
'To Chnage Values of Row....
Range(Cell1).Offset(0, i).Select
'To Chnage Values of Colum....
'Range(Cell1).Offset(i,0).Select
If IsNumeric(ActiveCell.Value) = True Then
ActiveCell.Value = Val(ActiveCell.Value) + ValueToChange
End If
Next i
Else
MsgBox ("Select Row only...")
End If
End Sub
range() function input is cell address, for example, range(a1:b2;g1:h4), you cannot input some result in it.