The below code is working fine with me. I need your help and support to make it a function so I can for example write in any cell
=adj() or =adj(A1) and the formula will apply,
Sub adj()
Dim i, j As Integer
Sheet1.Select
With Sheet1
j = Range(ActiveCell.Offset(0, -2), ActiveCell.Offset(0, -2)).Value
For i = 1 To j
ActiveCell.Formula = "=" & Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, -1)) & i & "))" & "&char(10)"
Next i
End With
End Sub
It's hard for me to definitively understand what you're trying to do here. I think you're trying to concatenate x number of cells with a separator field.
So, I would do the following changes... obviously you can change accordingly.
Declare the Inputs as variants. If you don't and get a type mismatch the function wont call in debug. This also gives you the opportunity to deal with the Inputs.
Put in an error handler to prevent unwanted debug w.r.t. a failure.
You can't use Evaluate that way. I think you're trying to get an Evaluation of cells like A1 etc.
The function has to be called from a Cell on a sheet since it uses Application.Caller. You shouldn't really need this for the function to work, but I put in in there in case you are calling via F9 calculation.
You can also put in the line if you want the calculation to occur every time you recalculate. However this should be used with caution since you can get some unwanted calculation side effects with some spreadsheets when using this.
Application.Volatile
Public Function Adj(ByVal x As Variant, ByVal y As Variant) As String
On Error GoTo ErrHandler
Dim sSeparator As String, sCol As String
Dim i As Integer
'Get the column reference.
sCol = Split(Columns(y).Address(False, False), ":")(1)
'Activate the sheet.
Application.Caller.Parent.Select
sSeparator = Chr(10)
For i = 1 To x
Adj = Adj & Evaluate(sCol & i) & sSeparator
Next
'Remove the last seperator...
Adj = Left(Adj, Len(Adj) - 1)
Exit Function
ErrHandler:
'Maybe do something with the error return value message here..
'Although this is a string, Excel will implicitly convert to an error.
Adj = "#VALUE!"
End Function
If you wanted to pass change to a formula, and pass in the range, you would use something like:
Public Function Func(Byval MyRange as range) as variant
In this case, you're not specifying a return value so it will be ignored.
Public Function Func(Byval MyRange as range) as variant
Dim i, j As Integer
With MyRange.parent
j = .Range(MyRange.Offset(0, -2), MyRange.Offset(0, -2)).Value
For i = 1 To j
MyRange.Formula = "=" & .Range(MyRange.Offset(0, -1), MyRange.Offset(0, -1)) & i & "))" & "&char(10)"
Next i
End With
End Sub
It would be something like that..
Related
Sub test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False 'keeping the screen clean
Sheets("Data").Select
'Here is where the error is triggered.
With ThisWorkbook.Worksheets("TestSheet")
'.Range("A2:A" & Lr).Formula = "=CusVlookup(Z2,Data'!A:B,2)" <- this doesnt work either
.Range("A2:A" & Lr) = "=CusVlookup(Z2,Data'!A:B,2)"
End With
End Sub
Function CusVlookup(lookupval, LookupRange As Range, indexcol As Long)
Dim x As Range
Dim Result As String
Result = ""
For Each x In LookupRange
If x = lookupval Then
Result = Result & "," & x.Offset(0, indexcol - 1)
End If
Next x
CusVlookup = Result
End Function
I've tried using the regular Vlookup and works just fine but if I try to use this custom function it triggers the error. By the way I need to get the multiple matches "vlookups" into one cell separated by comma.(I added the goal just in case you know a better/faster way to do the same.)
whats wrong with the code?
Error 1004 - Application-defined or object-defined error
My questions is: How can I add multiple vLookup-formulas into one cell over VBA?
I know that I can add one vLookUp like this:
... = Application.WorksheetFunction.vLookUp("Search","Matrix","Index")
My Problem is: I have a workbook with 255 pages and in my "sum-sheet" I need variable formulas that search in those 255 worksheets for the data I need.
So the output of the macro in excel needs to be something like (all of in one cell):
=vLoookUp($A2;Sheet1!A1:A1000;2)+SVERWEIS($A2;Sheet2!A1:A1000;2)+ ...(255 times)
Is it even possible to do something like that with VBA?
This is the code I used to split the different options into the 255 sheets:
This is the code I wrote so far to split the different variations of stocks:
(Its somewhat working but I'm kind of sure its not very efficient, I'm new to all this Programming Stuff)
Sub Sheets()
Application.ScreenUpdating = False
ActiveWindow.WindowState = xlMinimized
Dim Data As String
Dim i As Long
Dim k As Long
Dim x As Long
Dim y As String
For i = 2 To 255
Sheetname = Worksheets("Input").Cells(i, 1).Value
Worksheets.Add.Name = Sheetname
ActiveSheet.Move After:=Worksheets(ActiveWorkbook.Sheets.Count)
x = 1
For k = 2 To 876
Data = Worksheets("Input").Cells(i, k).Value
y = Cells(1, x).Address(RowAbsolute:=False, ColumnAbsolute:=False)
BloomB = "=BDH(" & y & ",""TURNOVER"",""8/1/2011"",""4/30/2016"",""Dir=V"",""Dts=S"",""Sort=A"",""Quote=C"",""QtTyp=Y"",""Days=T"",""Per=cd"",""DtFmt=D"",""UseDPDF=Y"")"
Worksheets(Sheetname).Cells(1, x) = Data
Worksheets(Sheetname).Cells(2, x) = BloomB
x = x + 2
Next k
Application.Wait (Now + TimeValue("0:00:05"))
Next i
ActiveWindow.WindowState = xlMaximized
Application.ScreenUpdating = True
End Sub
Sorry, but this sounds like a very bad design. Maybe Access or SQL Server would be better suited for this kind of task. Also, you know the VLOOKUP function will return the first match, but no subsequent matches, right. Just want to make you aware of that. Ok, now try this.
Function VLOOKAllSheets(Look_Value As Variant, Tble_Array As Range, _
Col_num As Integer, Optional Range_look As Boolean)
''''''''''''''''''''''''''''''''''''''''''''''''
'Written by OzGrid.com
'Use VLOOKUP to Look across ALL Worksheets and stops _
at the first match found.
'''''''''''''''''''''''''''''''''''''''''''''''''
Dim wSheet As Worksheet
Dim vFound
On Error Resume Next
For Each wSheet In ActiveWorkbook.Worksheets
With wSheet
Set Tble_Array = .Range(Tble_Array.Address)
vFound = WorksheetFunction.VLookup _
(Look_Value, Tble_Array, _
Col_num, Range_look)
End With
If Not IsEmpty(vFound) Then Exit For
Next wSheet
Set Tble_Array = Nothing
VLOOKAllSheets = vFound
End Function
The full description of everything is here.
http://www.ozgrid.com/VBA/VlookupAllSheets.htm
I am trying to pass the line column value to the sub that will call a function to calculate some logic.
Before writing a sub I just defined a function and passed values manually to the function and dragging to the columns I needed.
But now I wanted to create something that will auto apply formula to a range of the column.
This is the code I am trying to do, maybe its not the best way but open for suggestions.
Function addDiscount(Qty, Price)
'
' addDiscount Macro
' adds Discount to given price and quantity
'
' Keyboard Shortcut: Ctrl+h
If (Qty >= 10 Or Price >= 200) Then
addDiscount = 30 * 0.01
Else
addDiscount = 0
End If
addDiscount = Application.Round(addDiscount, 2)
End Function
Sub insertAddDiscount()
Sheets("Sheet1").Select
Range("F9:F30").Select
Dim i As Integer
For i = 9 To 30
Selection.Formula = "=addDIscount($G$i,$E$i)"
Selection.Columns.AutoFit
Next i
End Sub
Since you are using a variable i inside the formula, you need to take it outside the ".
replace your line:
Selection.Formula = "=addDIscount($G$i,$E$i)"
with:
Selection.Formula = "=addDIscount($G" & i & ",$E" & i & ")"
However, let me suggest a solution, where you don't need to rely on Selecting the Range, and later on use Selection, but rely on fully qualified Range object (this will also shorten your code's run-time).
Sub insertAddDiscount()
Dim i As Long
With Sheets("Sheet1")
For i = 9 To 30
.Range("F" & i).Formula = "=addDIscount($G" & i & ",$E" & i & ")"
Next i
.Range("F9:F30").Columns.AutoFit
End With
End Sub
I am trying to write a macro in Excel to calculate the standard deviation of same text in column A taking the values from column B and giving the results in column C:
I did it manually by putting the equation=STDEV.S(A2;A3;A4;A16)for "aaa". But I need to do this automatically because I am doing another calculation and procedures which are completing by macros. Here is my code:
Option Explicit
Sub Main()
CollectArray "A", "D"
DoSum "D", "E", "A", "B"
End Sub
' collect array from a specific column and print it to a new one without duplicates
' params:
' fromColumn - this is the column you need to remove duplicates from
' toColumn - this will reprint the array without the duplicates
Sub CollectArray(fromColumn As String, toColumn As String)
ReDim arr(0) As String
Dim i As Long
For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
arr(UBound(arr)) = Range(fromColumn & i)
ReDim Preserve arr(UBound(arr) + 1)
Next i
ReDim Preserve arr(UBound(arr) - 1)
RemoveDuplicate arr
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
For i = LBound(arr) To UBound(arr)
Range(toColumn & i + 1) = arr(i)
Next i
End Sub
' sums up values from one column against the other column
' params:
' fromColumn - this is the column with string to match against
' toColumn - this is where the SUM will be printed to
' originalColumn - this is the original column including duplicate
' valueColumn - this is the column with the values to sum
Private Sub DoSum(fromColumn As String, toColumn As String, originalColumn As String, valueColumn As String)
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
Dim i As Long
For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
Range(toColumn & i) = WorksheetFunction.SumIf(Range(originalColumn & ":" & originalColumn), Range(fromColumn & i), Range(valueColumn & ":" & valueColumn))
Next i
End Sub
Private Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B
tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub
It would be nice if someone could please give me an idea or solution. The above code is for calculating the summation of same text values. Is there any way to modify my code to calculate the standard deviation?
I went in a different direction and provided a pseudo-STDEV.S.IF to be used much like the COUNTIF or AVERAGEIF function.
Function STDEV_S_IF(rAs As Range, rA As Range, rBs As Range)
Dim a As Long, sFRM As String
sFRM = "STDEV.s("
Set rBs = rBs(1).Resize(rAs.Rows.Count, 1)
For a = 1 To rAs.Rows.Count
If rAs(a).Value2 = rA.Value2 Then
sFRM = sFRM & rBs(a).Value2 & Chr(44)
End If
Next a
sFRM = Left(sFRM, Len(sFRM) - 1) & Chr(41)
STDEV_S_IF = Application.Evaluate(sFRM)
End Function
Syntax: STDEV_S_IF(<criteria range>, <criteria>, <stdev.s values>)
In your sample, the formula in C2 would be,
=STDEV_S_IF(A$2:A$20, A2, B$2:B$20)
Fill down as necessary.
Here is a formula and VBA route that gives you the STDEV.S for each set of items.
Picture shows the various ranges and results. My input is the same as yours, but I accidentally sorted it at one point so they don't line up.
Some notes
ARRAY is the actual answer you want. NON-ARRAY showing for later.
I included the PivotTable to test the accuracy of the method.
VBA is the same answer as ARRAY calculated as a UDF which could be used elsewhere in your VBA.
Formula in cell D3 is an array formula entered with CTRL+SHIFT+ENTER. That same formula is in E3 without the array entry. Both have been copied down to the end of the data.
=STDEV.S(IF(B3=$B$3:$B$21,$C$3:$C$21))
Since it seems you need a VBA version of this, you can use the same formula in VBA and just wrap it in Application.Evaluate. This is pretty much how #Jeeped gets an answer, converting the range to values which meet the criteria.
VBA Code uses Evaluate to process a formula string built from the ranges given as input.
Public Function STDEV_S_IF(rng_criteria As Range, rng_criterion As Range, rng_values As Range) As Variant
Dim str_frm As String
'formula to reproduce
'=STDEV.S(IF(B3=$B$3:$B$21,$C$3:$C$21))
str_frm = "STDEV.S(IF(" & _
rng_criterion.Address & "=" & _
rng_criteria.Address & "," & _
rng_values.Address & "))"
'if you have more than one sheet, be sure it evalutes in the right context
'or add the sheet name to the references above
'single sheet works fine with just Application.Evaluate
'STDEV_S_IF = Application.Evaluate(str_frm)
STDEV_S_IF = Sheets("Sheet2").Evaluate(str_frm)
End Function
The formula in F3 is the VBA UDF of the same formula as above, it is entered as a normal formula (although entering as an array does not affect anything) and is copied down to the end.
=STDEV_S_IF($B$3:$B$21,B3,$C$3:$C$21)
It is worth noting that .Evaluate processes this correctly as an array formula. You can compare this against the NON-ARRAY column included in the output. I am not certain how Excel knows to treat it this way. There was previously a fairly extended conversion about how Evaluate process array formulas and determines the output. This is tangentially related to that conversation.
And for completeness, here is the test of the Sub side of things. I am running this code in a module with a sheet other than Sheet2 active. This emphasizes the ability of using Sheets("Sheets2").Evaluate for a multi-sheet workbook since my Range call is technically misqualified. Console output is included.
Sub test()
Debug.Print STDEV_S_IF(Range("B3:B21"), Range("B3"), Range("C3:C21"))
'correctly returns 206.301357242263
End Sub
I would like to run a function called ToNum on every cell in a row with a value that will convert a cell contents to a string. Here is my code below but I am getting a compile error, can anyone assist and let me know what I am doing wrong?
Sub ConvRows()
Dim rng As Range
Dim cell As Variant
Set rng = Range("A8:A" & Range("A" & Rows.Count).End(xlUp).Row).Select
For Each cell In rng
cell.Value = ToNum(cell.Value)
Next
End Sub
Function ToNum(X As Variant) As String
Dim A As String
A = Trim(Str(X))
ToNum = A
End Function
I would add this as a comment, but I don't have enough reputation points to comment. To avoid the type mismatch error on cells that already contain a string, you could put your call to ToNum in an if statement in your subroutine like this:
If IsNumeric(cell.Value) Then
cell.Value = ToNum(cell.Value)
End If
That should keep the subroutine from touching cells that are already strings.
Consider:
Function ToNum(X As Variant) As String
Dim A As String
A = Trim(Str(X))
ToNum = "'" & A
End Function