I am working with a module that involves many functions that are almost identical except for the sub function that is called within. (The arguments are the same, and the loops run the same.)
An example of such a function is the following:
Function Run1(lookupString) As Boolean
For i = 1 To nA
For j = 1 To nB
Checkbox = ThisWorkbook.Sheets(i).Cells(j,1)
If Checkbox = lookupString
RunLocation(Checkbox)
Run1 = True
Exit Function
End If
Next j
Next i
Run1 = False
End Function
I have other functions that are identical except for the call to "RunLocation" which is different inside the other functions. Is there a way to have just one function in this form but include the sub function that it calls as an argument?
Try something like this:
Function Run1(lookupString, procName As String) As Boolean
For i = 1 To nA
For j = 1 To nB
CheckBox = ThisWorkbook.Sheets(i).Cells(j, 1)
If CheckBox = lookupString Then
'RunLocation (CheckBox)
Application.Run "'" & ThisWorkbook.Name & _
"'!Module1." & subName, CheckBox
'Adust "Module1" to whatever is the name of the
' code module with the methods you want to run...
Run1 = True
Exit Function
End If
Next j
Next i
Run1 = False
End Function
EDIT: use of Evaluate, and an interesting way to use a UDF to directly update a worksheet (something normally tricky to do...)
'************* a few test methods to call *******************
'just return the value
Function DoIt(c As Range)
DoIt = "Value is " & c.Value
End Function
'change the value
Function DoIt2(c As Range)
c.Value = 33
DoIt2 = "Value is " & c.Value
End Function
'a sub instead of a function
Sub DoIt3(c1 As Range, c2 As Range)
c1.Value = c2.Value
c1.Interior.Color = IIf(c1.Value > 10, vbRed, vbYellow)
End Sub
'******************** end test methods ***********************
Sub Tester()
'A1=22
Debug.Print ActiveSheet.Evaluate("=DoIt(A1)") '>> Value is 22
Debug.Print ActiveSheet.Evaluate("=DoIt2(A1)") '>> Value is 33
ActiveSheet.Evaluate "DoIt3(A1,A2)" '>> Sets A1 to A2
End Sub
'######## run as a UDF, this actually changes the sheet! ##############
' changing value in src updates dest and set interior color
Function Tester2(dest, src)
dest.Parent.Evaluate "DoIt3(" & dest.Address(False, False) & "," _
& src.Address(False, False) & ")"
Tester2 = "Changed sheet!"
End Function
Related
I have this code but its hard coded. I need it to be automated in a loop or something else instead of a case statement till the empty column stops but more column will be added in a form. So the range can go from B2 to the late column in the excel sheet only if the column header is there and then it stops. It will shows the content in each column. Please note the excel sheet is called Area
Can this be done?
Private Sub ComboBox3_Change()
Dim i As Long
i = ComboBox3.ListIndex
ComboBox4.Clear
Select Case i
Case Is = 0
With Worksheets("Area")
ComboBox4.List = .Range("**B2:B**" & .Range("**b**" & Rows.Count).End(xlUp).Row).Value
End With
Case Is = 1
With Worksheets("Area")
ComboBox4.List = .Range("**C2:C**" & .Range("**c**" & Rows.Count).End(xlUp).Row).Value
End With
Case Is = 2
With Worksheets("Area")
ComboBox4.List = .Range("**D2:D**" & .Range("**d**" & Rows.Count).End(xlUp).Row).Value
End With
Case Is = 3
With Worksheets("Area")
ComboBox4.List = .Range("**E2:E**" & .Range("**e**" & Rows.Count).End(xlUp).Row).Value
End With
Case Is = 4
With Worksheets("Area")
ComboBox4.List = .Range("**F2:F**" & .Range("**f**" & Rows.Count).End(xlUp).Row).Value
End With
End Select
End Sub
Something like this should work for you:
Private Sub ComboBox3_Change()
Dim ws As Worksheet
Dim ColNum As Long
Set ws = ActiveWorkbook.Sheets("Area")
ColNum = Me.ComboBox3.ListIndex + 2
Me.ComboBox4.Clear
If ColNum < 2 Then Exit Sub 'Nothing selected
Me.ComboBox4.List = ws.Range(ws.Cells(2, ColNum), ws.Cells(ws.Rows.Count, ColNum).End(xlUp)).Value
End Sub
If you want to enumerate the column number into column name use Chr(65) where 65 is the ASCII value for A.
In your case add 66 to your integer i like Chr(66+i) which returns B
Also, there is a function to convert column number into column name in excel, =SUBSTITUTE(ADDRESS(1,col_number,4),"1","") although I haven't tried it in VBA.
In your specific case, you don't need a case statement at all
Private Sub ComboBox3_Change()
Dim i As Long
i = ComboBox3.ListIndex
ComboBox4.Clear
With Worksheets("Area")
ComboBox4.List = .Range("**E2:E**" & .Range("**e**" & Rows.Count).End(xlUp).Row).Offset(0,i).Value
End Sub
might need some tweaking since I can't test it out. But offset by 0 rows and i columns is the best solution for you
I am coding a VBA function to merge two cells and then highlight the text of cell 2 with bold formatting
The merging goes well
The call to Sub goes well
But the text format is not applied
I believe it might be caused by the sub executing before the cell is populated with the string - but that's pure guessing - this is my first VBA script
Function boldIt(navn As String, ekstra As String)
Dim ln1 As Integer
Dim ln2 As Integer
Dim st1 As String
ln1 = Len(navn)
ln2 = Len(navn) + Len(ekstra)
If (ln1 = ln2) Then
boldIt = navn
Else
boldIt = navn & " - " & ekstra
boldTxt ln1, ln2
End If
End Function
Public Sub boldTxt(startPos As Integer, charCount As Integer)
With ActiveCell.Characters(Start:=startPos, Length:=charCount).Font
.FontStyle = "Bold"
End With
End Sub
I think I would just run two subs; the function is not returning anything.
Option Explicit
Sub boldIt()
Dim secondOne As String
With Selection
secondOne = .Cells(2).Value2
Application.DisplayAlerts = False
.Merge
Application.DisplayAlerts = True
.Cells(1) = .Cells(1).Value2 & secondOne
boldTxt .Cells(1), Len(.Cells(1).Value2) - Len(secondOne) + 1, Len(secondOne)
End With
End Sub
Public Sub boldTxt(rng As Range, startPos As Integer, charCount As Integer)
With rng.Characters(Start:=startPos, Length:=charCount).Font
.FontStyle = "Bold"
End With
End Sub
This Sub loops through the columns, takes the strings of the two cells, combines the strings and add them to the target cell, while bolding the text of the second cell
Thanks to #Jeeped for the pointers!
Sub boldIt()
Dim pos_bold As Integer
Dim celltxt As String
For i = 2 To 200000
' first cell will always be populated - if not - exit
If (Range("Plan!E" & i).Value = "") Then Exit For
' if second cell is empty - take only first cell as normal txt
If (Range("Plan!F" & i).Value = "") Then
Range("Kalender!F" & i).Value = Range("Plan!E" & i).Value
Else
' calculate start of bold text
pos_bold = Len(Range("Plan!E" & i).Value) + 1
' create the string
celltxt = Range("Plan!E" & i).Value & " - " & Range("Plan!F" & i).Value
' add string to field and add bold to last part
With Worksheets("Kalender").Range("F" & i)
.Value = celltxt
.Characters(pos_bold).Font.Bold = True
End With
End If
Next i
End Sub
I'am on VBA trying to create a macro that record in different cell the number of times the workbook is open. Each time it is open, it creates a new cell with the number of the opening. So I created a counter for that.
Option Explicit
Dim i As Integer
Private Sub Workbook_Open()
If i = "" Then
i = 1
End If
ThisWorkbook.Worksheets("Feuil1").Cells(i, 1).Value = "Session " & i
i = i + 1
Debug.Print i
End Sub
However, the statement If i = "" remains highlighted in yellow, and I don't understand why...
Would someone have a solution?
Thank you !
i is an Integer so comparison to an empty String is not valid.
The closest thing you can do is
If i = 0 Then
But if you want the value to i to persist when you save the workbook, the simplest thing to do is to read its value from the workbook.
Of course you cannot assign a string to an integer. This is a type mismatch error.
What you need is to fetch the last cell in the column and then increment it.
Private Sub Workbook_Open()
' Fetch the last cell from column 1
Dim r As Range
With ThisWorkbook.Worksheets("Feuil1")
Set r = .Cells(.Rows.Count, 1).End(xlUp)
End With
' Get the last session number, or 0 if not present or doesn't match
Dim lastSession As Long: lastSession = 0
If Not IsEmpty(r) Then
Dim p As Long: p = InStr(1, Trim(r.value), "Session ")
If p = 1 Then
lastSession = CLng(Mid(r.value, p + Len("Session "), 10000))
End If
End If
r.Offset(1).value = "Session " & (lastSession + 1)
End Sub
I'd go like follows
Private Sub Workbook_Open()
With Worksheets("Feuil1")
With .Cells(.Rows.Count, 1).End(xlUp)
.Offset(1) = "Session " & Val(Replace(.Value, "Session ", "")) + 1
End With
End With
End Sub
I have been trying to write a program that will loop through all the cells in an excel sheet and if one starts with a '#' it should display a message. here's the code:
(template is a worksheet variable)
Private Function processTemplate()
Dim total As Long
total = template.UsedRange.count
Dim count As Integer
count = 0
While count <= total
If template.Cells(count).Value Like "[#]*" Then 'Here I get a error
MsgBox "Found #"
End If
count = count + 1
Wend
End Function
I have isolated the error to using a variable inside of cells(). If I replace count with some number (like 8) it works fine. I am getting error 1004 on the line If template.Cells(count).Value Like "[#]*" Then
If I make total an Integer it has the same error at the same place. After about 2-3 hrs of research/banging my head on the wall I have no idea. I initially got the error when assigning template.cells(row, col).Value to a string variable.
Here's my code now:
Private Sub processTemplate()
MsgBox Len("")
Dim str As String
Dim rows As Long
Dim cols As Long
rows = template.UsedRange.Height
cols = template.UsedRange.Width
Dim row As Integer
row = 1
While row < rows
Dim col As Integer
col = 1
While col < cols
str = template.Cells(row, col).Text
If Len(str) > 0 Then
If Left(template.Cells(row, col).Text, 1) = "#" Then
MsgBox "Found IT"
End If
End If
Rem MsgBox template.Parent.Name & ": " & template.Name & ", Cell(" & row & ", " & col & "): " & template.Cells(row, col).Value
col = col + 1
Wend
row = row + 1
Wend
End Sub
Now I get the error on str = template.Cells(row, col).Text
We can use a sub rather than a function
We loop over all the cells in UsedRange looking for a # as the first character in the cell.
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
Next r
End Sub
EDIT#1
This version loops over all the cells, but does not test cells containing formulas
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If r.HasFormula = False Then
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
End If
Next r
End Sub
You could use find/ find next function which i guess bit faster than looping through each cell and do string comparison.
With Worksheets(1).Range("a1:a500") 'Provide the search range
Set c = .Find(2, lookin:=xlValues) ' searching for 2 in cell value
If Not c Is Nothing Then
firstAddress = c.Address 'first occurance
Do
'do whatever you want to do with the matches even replace them
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Reference:
http://msdn.microsoft.com/en-us/library/office/ff196143(v=office.15).aspx
I have Finally got some working code but Im getting a "type mismatch" error once the Module2 function finishes and I have no idea why.
If I step through it, it steps through "End function" on module2 then I get a Type Mismatch, but it does send the email. Any help would be great
This VBA code is in 3 parts.
1 Sub
Sub Workbook_open()
Call Module1.GetData
End Sub
2 Module 1
Public EmailAddress As String
Public CompanyNumber As String
Public Name As String
Public GroupComp As String
Function GetData()
Dim LastRow As String
Dim rng As Range
LastRow = Cells(Rows.Count, "K").End(xlUp).Row
For Each rng In Range("K2:K" + LastRow)
If Not rng.Value = vbNullString Then
Select Case rng.Value
Case 1
Case Is = "True"
Let EmailAddress = ActiveCell.Offset(0, -5).Value
Let CompanyNumber = ActiveCell.Offset(0, -9).Value
Let Name = ActiveCell.Offset(0, -8).Value
Let GroupComp = ActiveCell.Offset(0, -7).Value
Call Module2.Email(EmailAddress, CompanyNumber, Name, GroupsComp)
Case 2
Case Is = "False"
End Select
End If
Next
End Function
3 Module 2
Function Email()
'MsgBox (EmailAddress)
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Stuffl " & (GroupComp)
objMessage.From = "Department Name(Department#Email.com)"
objMessage.Cc = "Department Name(Department#Email.com)"
objMessage.To = (EmailAddress)
MsgBox (EmailAddress)
objMessage.TextBody = "TEST"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "x.x.x.x"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
End Function
Change the Function Email() into
Function Email(emailaddress As String, companynumber As String, name As String, groupscomp As String)
You are not actually calling the Mail function , that's the problem i think
"i dont understand why I had to specify the variables again in the mail"
Whenever you pass values to a Sub or Function, you have to define that Sub or Function such that it is expecting to have values passed to it. So this won't work:
Sub Foo()
Dim i as Integer
i = 5
Call Bar(i)
End Sub
Sub Bar()
i = i + 2
End Sub
Because Bar() isn't expecting to have anything passed to it. This will work:
Sub Foo()
Dim i as Integer
i = 5
Call Bar(i)
End Sub
Sub Bar(i as Integer)
i = i + 2
End Sub
Because you have now told Bar to expect an integer to be passed to it.
Hope that helped.