I made the below Public Function to choose a quarter based on the month number in my data.
Public Function quarter()
Dim Number As Integer
Dim quarterChosen As String
Number = Worksheets("Sheet1").Cells(Application.ActiveCell.Row, 2).Value
Select Case Number
Case 1 To 3
quarterChosen = "Q1"
Case 4 To 6
quarterChosen = "Q2"
Case 7 To 9
quarterChosen = "Q3"
Case 10 To 12
quarterChosen = "Q4"
End Select
quarter = quarterChosen
End Function
It works but when I drag it down to copy it down it stills considers the active cell the original cell started at. I need to rewrite the formula to get the result I want. How do I get that active cell to change as I drag or copy it down?
Pass your input cell as an argument of your function (and add an output type), along the line of this.
So you enter the formula in B1 =quarter(A1).
Public Function quarter(r As Range) As String
Dim quarterChosen As String
Select Case r.Value
Case 1 To 3: quarter = "Q1"
Case 4 To 6: quarter = "Q2"
Case 7 To 9: quarter = "Q3"
Case 10 To 12: quarter = "Q4"
Case Else: quarter = "n/a"
End Select
End Function
You should use Application.Volatile in the upper part of your function. I've just wrote this one for you and all works my end :)
Public Function Quarter(arg1 As Long)
Dim quarterChosen As String
Application.Volatile
Select Case arg1
Case 1 To 3
quarterChosen = "Q1"
Case 4 To 6
quarterChosen = "Q2"
Case 7 To 9
quarterChosen = "Q3"
Case 10 To 12
quarterChosen = "Q4"
End Select
Quarter = quarterChosen
End Function
You should also pass the function the cell you want to evaluate.
Related
I have column with comments in it (more then 5000 cases).
Those comments have text, numbers, date, everything.
I need to get phone number out of those comments.
Phone numbers are in random places for every comment, so LEFT,MID or RIGHT will not work
The closest result that I have reached is with Kutools =EXTRAXTNUMBERS() ...... but I get a line of numbers which includes date, ID`s, etc.
Would prefer a formula. :)
Two sample comments below, required phone numbers are in bold
Thursday, February 2, 2017 2:37 PM Coordinated Universal Time .3868 67076939 ,pers .pārv.Tatjana Call outcome chosen: Noruna citā laikā - 2017-02-03 07:15 Wednesday, February 8, 2017 8:18 AM Coordinated Universal Time .3868 nr.67074071-neeksistē,personāla daļas vad.Tatjana neatbild,arī nr.67076600 Call outcome chosen: Neceļ Friday, February 10, 2017 7:15 AM Coordinated Universal Time * .3868 *** piezv ap 13 Call outcome chosen: Noruna citā laikā - 2017-02-10 11:15
Thursday, February 2, 2017 11:15 AM Coordinated Universal Time 4213 zvanīt 66119908 Call outcome chosen: Noruna citā laikā - 2017-02-07 09:00 Tuesday, February 14, 2017 12:59 PM Coordinated Universal Time .4532 * anita#dzintarniece#rtp.lv Call outcome chosen: Turpināt internetā
This small UDF() will return all the 8 digit numeric sub-strings in a string:
Public Function PHNum(s As String) As String
Dim L As Long, i As Long, temp As String
Dim CH As String
L = Len(s)
temp = ""
PHNum = ""
For i = 1 To L
CH = Mid(s, i, 1)
If IsNumeric(CH) Then
temp = temp & CH
If Len(temp) = 8 Then
PHNum = PHNum & vbCrLf & temp
End If
Else
temp = ""
End If
Next i
End Function
Note:
To get the stacked format in the output cell, format it to wrap on.
Regexp Solution
This UDF extracts to you the phone numbers from a Text, as an array. You can eventually use Join to transform it into a csv string, or you can paste the array into a range of cells.
Function extractPhones(s As String) As String()
Dim i As Long, matches, match, ret
With CreateObject("VBScript.Regexp")
.Global = True
.Pattern = "\W[26]\d{7}\W"
Set matches = .Execute(s)
End With
ReDim ret(1 To matches.Count) As String
For Each match In matches
i = i + 1
ret(i) = Mid(match, 2, Len(match) - 2)
Next
extractPhones = ret
End Function
It uses a regular expression that matches phone number with these specs:
are exactly 8 digits
start by 6 or 2
are not preceded or followed by an alphanumeric letter, but by blanks or punctuation characters.
Using an UDF you can accomplish this by using the following code:
To use it:
Press ALT + F11
Insert Module
Paste Code
In Excel Sheet, use this formula =get_phone("CELL_WITH_NUMBER_HERE") to get the first sequence of 8 digits in your cell.
Code:
Public Function get_phone(cell As Range)
Dim s As String
Dim i As Integer
Dim num
Dim counter As Integer
'get cell value
s = cell.Value
'set the counter
counter = 0
'loop through the entire string
For i = 1 To Len(s)
'check to see if the character is a numeric one
If IsNumeric(Mid(s, i, 1)) = True Then
'add it to the number
num = num + Mid(s, i, 1)
counter = counter + 1
'check if we've reached 8 digits
If counter = 8 Then
get_phone = num
Exit Function
End If
Else
'was not numeric so reset counter and answer
counter = 0
num = ""
End If
Next i
End Function
Example Image:
Another regexp option that returns all matches to a single cell
See https://regex101.com/r/Hdv65h/1
Function StrPhone(strIn As String) As String
Dim objRegexp As Object
Set objRegexp = CreateObject("VBScript.Regexp")
With objRegexp
.Global = True
.Pattern = ".*?(\d{8})|.*$"
StrPhone = Trim(.Replace(strIn, "$1 "))
End With
End Function
There is add-on in Excel that I used in the past for regular expressions (http://seotoolsforexcel.com/regexpfind/). In your case, it could be complicated as you don't know how many times a phone number will appear in your cell. For these cases I suggest you use the VBA scripts that have been provided by other users.
I have two "combo boxes" and one "txtbox" in my userform, In workbook "sheet1" i have names on column A and Month on column B and columns C to N are Jan. to Dec. which contain production hours for each name/specific month
-cboName
-cboMonth
-txtHours
I use below code to populate txtHours
Private Sub cboName_Change()
Dim EName As String
Dim Row, Col As Integer
EName = Me.cboName.Text
If EName <> "" Then
With Application.WorksheetFunction
Row = .Match(EName, Sheets("sheet1").Range("A2:A100"), 0)
GetMonthNum (Me.cboMonth.Text)
txtShiftHours.Value = Sheets("sheet1").Cells(Row + 1, Col + 3)
End With
End If
End Sub
Private Sub GetMonthNum(Month As String)
Select Case Month
Case Jan
Col = 3
Case Feb
Col = 4
Case Mar
Col = 5
Case Apr
Col = 6
Case May
Col = 7
Case June
Col = 8
Case July
Col = 9
Case Aug
Col = 10
Case Sept
Col = 11
Case Oct
Col = 12
Case Nov
Col = 13
Case Dec
Col = 14
End Select
End Sub
but regardless of month selection on cboMonth,txtProduct is populated with column 3 cuz this line
txtShiftHours.Value = Sheets("sheet1").Cells(Row + 1, Col + 3)
Please help me
thanks
You had several issues:
Your Case statements were checking the value of the String variable Month against undefined variables such as Jan, Feb, etc. This should have been checking against String literals such as "Jan", "Feb", etc.
In your GetMonthNum subroutine, you were assigning a value to an undefined variable Col.
In your cboName_Change subroutine you were using a variable Col which had never been assigned a value, so it would have had the default value of zero.
You also had some minor issues, which wouldn't have stopped your code from working, but could lead to problems down the track:
You used several variable names (Row, Month) which are the same as built in Functions / Properties within VBA. This is usually a very bad idea.
You declared Row as a Variant, despite declaring Col as an Integer.
It's a good idea to define row and column variables to be Long rather than Integer - the maximum number of rows in Excel is now 1048576, but an Integer can only hold numbers up to 65536.
It is also a good idea to always include the Option Explicit statement as the first line of each of your code modules. This tells the compiler to check that all your variables have been declared, and thus prevents many typos and attempts to use variables in one subroutine which are local to another subroutine.
I have refactored your code and hopefully it should now work.
Option Explicit
Private Sub cboName_Change()
Dim EName As String
Dim RowNum As Long, ColNum As Long
EName = Me.cboName.Text
If EName <> "" Then
With Application.WorksheetFunction
RowNum = .Match(EName, Sheets("sheet1").Range("A2:A100"), 0)
ColNum = GetMonthNum(Me.cboMonth.Text) + 2
txtShiftHours.Value = Sheets("sheet1").Cells(RowNum + 1, ColNum)
End With
End If
End Sub
Private Function GetMonthNum(Mth As String) As Long
Select Case Mth
Case "Jan": GetMonthNum = 1
Case "Feb": GetMonthNum = 2
Case "Mar": GetMonthNum = 3
Case "Apr": GetMonthNum = 4
Case "May": GetMonthNum = 5
Case "June": GetMonthNum = 6
Case "July": GetMonthNum = 7
Case "Aug": GetMonthNum = 8
Case "Sept": GetMonthNum = 9
Case "Oct": GetMonthNum = 10
Case "Nov": GetMonthNum = 11
Case "Dec": GetMonthNum = 12
End Select
End Function
You could use some of Excel's Date & Time built-in functions, to replace your entire Private Sub GetMonthNum(Month As String) with the 1 line of code below:
ColNum = Month(DateValue("1/" & Me.cboMonth.Text & "/2017")) + 2
Explanation: since your cboMonth Combo-Box has month strings in the mmm month format. If you select "Feb", then when you get to this section ("1/" & Me.cboMonth.Text & "/2017") you are getting "1/Feb/2017".
When adding DateValue before, you get 1/Feb/2017, and when adding the Month before, the result is 2.
I wrote a macro to check the value being entered in some cells.
If the input is higher than 8 the excess is written to another cell and the input is changed to 8. If the input is lower than 8 the missing amount is written to a third cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
TA = Target.Address: R = Target.Row: C = Target.Column
If C = 2 Or C = 7 Then
If (R < 19 And R > 11) Or (R < 33 And R > 25) Then
Hours = Cells(R, C).Value
If Hours <> 0 Then
If Hours > 8 Then
Cells(R, C) = 8
Cells(R, C + 1) = Hours - 8
End If
If Hours < 8 Then
Cells(R, C + 2) = 8 - Hours
End If
End If
End If
End If
End Sub
The problem is the macro is not executed when I enter the input, only when I select the cell again.
First change your trigger event from Worksheet_SelectionChange to Worksheet_Change.
Second, you can optimize your code, since you can read the Column and Row property of Target, you can save a few rows in your code.
Third, I modified your test condition for checking the row, by switching to Select Case you can now add more rows to this condition easily.
Use Target.offset to insert the result in the neighbour cells.
I added Exit Sub so it won't run an extra time after you change the values here.
If you want, you can also remove the Hours as it is not needed (unless you have a global variable that somehow reads this value).
You can just use If Target.Value <> 0 Then etc.)
Private Sub Worksheet_Change(ByVal Target As Range)
' check if target is in Column B or Column G
If Target.Column = 2 Or Target.Column = 7 Then
Select Case Target.Row
Case 12 To 18, 26 To 32 ' check if target row is 12 to 18 (including) ir between 26 to 32 (including)
Hours = Target.Value
If Hours <> 0 Then
If Hours > 8 Then
Target.Value = 8
Target.Offset(0, 1).Value = Hours - 8
Exit Sub
Else
If Hours < 8 Then
Target.Offset(0, 2).Value = 8 - Hours
End If
Exit Sub
End If
End If
End Select
End If
End Sub
Your function Worksheet_SelectionChange only fires when the selected cell is changed. You should use Worksheet_Change instead. You can see this automatically execute an Excel macro on a cell change for more details.
I would like a textbox, "txtWeek," to show the number of Fridays or Thursdays between the beginning of the month to the current date, IE I have started with
Dim MyDate, MyStr
MyDate = Format(Now, "M/d/yy")
Me.txtDate.Value = MyDate
Dim Day As Variant
ReDim Day(2)
Day = Array("Thursday", "Friday")
ComboBox1.ColumnCount = 1
ComboBox1.List() = Day
Dim X, AsDate
X = Format(Now, "M/1/yy")
If Me.ComboBox1.Text = "Friday" Then
Me.txtWeek.Value = Int((Weekday(X - 6) - X + Me.txtDate.Value) / 7)
Else
End If
End Sub
Requirements:
To show in Textbox txtDate the date of the machine
To calculate the number of Fridays or Thursdays in the month of txtDate till the date of the machine
To show in Textbox txtWeek the number of Fridays or Thursdays as per prior point
Assumptions:
The Sheet1 of the workbook containing the procedures has two TextBoxes and one ComboBox
The Procedures will be triggered by the change events of the ComboBox, when user select the weekday to count
Copy this procedure in the Code Module of Sheet1 - Change Event for the ComboBox
Private Sub CmbBox1_Change()
Dim sWkDy As String
Dim dDte1 As Date
Dim bDayC As Byte
Dim bThu As Boolean, bFri As Boolean
Rem Set Weekday
sWkDy = Me.CmbBox1.Value
Select Case sWkDy
Case "Thursday": bThu = True
Case "Friday": bFri = True
Case Else: Exit Sub
End Select
Rem Set First date of the current month
dDte1 = 1 + WorksheetFunction.EoMonth(Date, -1)
Rem Counts the weekdays
bDayC = Dte_Days_Count_To_Today(dDte1, blThu:=bThu, blFri:=bFri)
Rem Set Current Date in `txtDate`
'Using format `mmm-dd-yyyy` to ease reading of the date independently of the format (American or International)
Me.TxtDate.Value = Format(Date, "mmm-dd-yyyy") 'change as required
Rem Set count of weekdays `txtWeek`
'Using this format to directly show the weekdays counted
Me.TxtWeek.Value = "Count of " & sWkDy & "s: " & bDayC 'change as required
End Sub
Copy these procedures in a standard module
'Ensure these Keywords are at the top of the module
Option Explicit
Option Base 1
This procedure sets the available options in the Combobox – Run this first, need to run only once
Private Sub CmbBox1_Set()
Dim aWkDys As Variant
aWkDys = [{"Thursday", "Friday"}]
With Me.CmbBox1
.ColumnCount = 1
.List() = aWkDys
End With
End Sub
This Function counts the numbers of days from the date entered as input date dDteInp to the actual date of the machine TODAY. The results are generated using arithmetic calculus and avoids the loop trough each of the dates in the range. It also gives the option to count various weekdays at once e.g.: to count Thursdays and Fridays from a given date till today call it this way Call Dte_Days_Count_To_Today(dDteInp, blThu:=True, blFri:=True)
Public Function Dte_Days_Count_To_Today(dDteInp As Date, _
Optional blSun As Boolean, Optional blMon As Boolean, _
Optional blTue As Boolean, Optional blWed As Boolean, _
Optional blThu As Boolean, Optional blFri As Boolean, _
Optional blSat As Boolean)
Dim aDaysT As Variant, bDayT As Byte 'Days Target
Dim bDayI As Byte 'Day Ini
Dim iWeeks As Integer 'Weeks Period
Dim bDaysR As Byte 'Days Remaining
Dim bDaysA As Byte 'Days Additional
Dim aDaysC(7) As Integer 'Days count
Rem Set Days Base
aDaysT = Array(blSun, blMon, blTue, blWed, blThu, blFri, blSat)
bDayI = Weekday(dDteInp, vbSunday)
iWeeks = Int((Date - dDteInp + 1) / 7)
bDaysR = (Date - dDteInp + 1) Mod 7
Rem Set Day Target Count
For bDayT = 1 To 7
bDaysA = 0
aDaysC(bDayT) = 0
If aDaysT(bDayT) Then
If bDaysR = 0 Then
bDaysA = 0
ElseIf bDayI = bDayT Then
bDaysA = 1
ElseIf bDayI < bDayT Then
If bDayI + bDaysR - 1 >= bDayT Then bDaysA = 1
Else
If bDayI + bDaysR - 8 >= bDayT Then bDaysA = 1
End If
Rem Target Day Total
aDaysC(bDayT) = iWeeks + bDaysA
End If: Next
Rem Set Results - Total Days
Dte_Days_Count_To_Today = WorksheetFunction.Sum(aDaysC)
End Function
Suggest to read the following pages to gain a deeper understanding of the resources used:
Option keyword,
Variables & Constants,
Data Type Summary,
Optional keyword,
Function Statement,
For...Next Statement,
If...Then...Else Statement,
Control and Dialog Box Events,
Select Case Statement,
WorksheetFunction Object (Excel)
This UDF will count the number of whatever day you pass into it, between two dates passed as longs.
Public Function HowManyDays(Sdate As Long, Edate As Long, Wday As Long)
Dim i
Dim MyCount As Long
For i = Sdate To Edate
If Weekday(i) = Wday Then MyCount = MyCount + 1
Next i
HowManyDays = MyCount
End Function
Wday represents the day of the week, eg. sunday=1, monday=2... etc.
I don't know if it changes to monday=1, tuesday=2 etc. on other systems, or if it's always sunday=1.
With this UserForm code, a textbox will show the number of anyday depending on the value in a combobox:
Private Sub CommandButton1_Click()
Dim Sdate As Long, Edate As Long, Wday As Long
Sdate = CLng(DateSerial(Format(Now, "yy"), Format(Now, "mm"), 1))
Edate = CLng(Now)
Select Case ComboBox1.Value
Case "Sunday"
Wday = 1
Case "Monday"
Wday = 2
Case "Tuesday"
Wday = 3
Case "Wednesday"
Wday = 4
Case "Thursday"
Wday = 5
Case "Friday"
Wday = 6
Case "Saturday"
Wday = 7
End Select
TextBox1.Value = HowManyDays(Sdate, Edate, Wday)
End Sub
Private Sub UserForm_Initialize()
Dim Day As Variant
ReDim Day(7)
Day = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
ComboBox1.ColumnCount = 1
ComboBox1.List() = Day
End Sub
The start date is currently set to the first of the current month.
If you don't want to click a button to perform the action you can take the code from the CommandButton1_Click() and put it in ComboBox1_Change(), that way it will update the textbox whenever the combobox changes.
I have the code below that's supposed to generate a string like
"XXXXX|XXXXX|XXXXX|XXXXX|XXXXX|XXXXX".
This represents 5 weekdays each across 6 weeks for scheduling I'm building.
I also want the first few X's to be black, the remainder red. For example, we might be part way through the second week, and I'll want the first 7 X's to be black, and all remainder red.
My code generates this string just fine. However, I can't figure out to make the color happen. I couldn't figure out how to color my actual string that gets returned from the function. So I tried adding a self cell reference (the TargetCell parameter), so that as soon as I build the string, I could color the result.
In my spreadsheet cell D3 I have the formula
=BuildColorString(A3, A4, A5, C2, C3, D3, B41:B45)
Don't worry much about the first 5 parameters or the last parameter. Focus on the 6th parameter, that is the self reference to D3.
Anyway, if I make that 5th parameter some totally different cell, the text in that cell gets colored correctly. However, if I try to color the result of what I'm generating, it doesn't work.
I realize I have a chicken-and-egg problem here. I can't figure out how to get past it.
I also tried splitting the string generation from the coloring. I put the coloring behind a button I push. It doesn't work. I can't seem to color the result of the function's string build.
Below is my code:
Function BuildColorString(BeginDate As Date, EndDate As Date, Holidays As Integer, AsOfDate As Date, HolidaysPassed As Integer, TargetCell As Range, rColors As Range)
Dim iDayCount As Integer
Dim iPosition As Integer
Dim iColor As Integer
Dim WIPDate As Date
Dim iWeekDay As Integer
' BUILD STRING
BuildColorString = ""
WIPDate = BeginDate
While WIPDate <= EndDate
iWeekDay = Weekday(WIPDate)
If (iWeekDay = 1) Then
'Sunday
Else
If (iWeekDay = 7) Then
'Saturday
If (WIPDate <> BeginDate) Then
BuildColorString = BuildColorString & "|"
End If
Else
'Weekday
BuildColorString = BuildColorString & "X"
End If
End If
WIPDate = WIPDate + 1
Wend
' COLORIZE STRING
WIPDate = BeginDate
iDayCount = 1
iPosition = 1
While WIPDate <= EndDate
iWeekDay = Weekday(WIPDate)
If (iWeekDay = 1) Then
'Sunday
Else
If (iWeekDay = 7) Then
'Saturday
If (WIPDate <> BeginDate) Then
iPosition = iPosition + 1
End If
Else
'Weekday
If (iPosition <= 5) Then
' BLACK, Prior Completed
iColor = rColors(1, 1).Characters(1, 1).Font.ColorIndex
Else
' GREEN, Recent Completed
iColor = rColors(3, 1).Characters(1, 1).Font.ColorIndex
End If
TargetCell(1, 1).Characters(iPosition, 1).Font.ColorIndex = iColor
' BuildColorString.Characters(iPosition, 1).Font.ColorIndex = vbRed 'rColor.Font.ColorIndex
iDayCount = iDayCount + 1
iPosition = iPosition + 1
End If
End If
WIPDate = WIPDate + 1
Wend
End Function