I wrote a program that totals the number of times X number of widgets are tested in a day based upon a start and end count. After a period of time a widget will fail and have to be replaced, thus the count will start back at zero. I am using a Select Case to compute the data and a drop-down menu in Excel to select the widget(s). Everything works great besides one thing... I can't select multiple widgets to search the Case.
I understand the general principles of the Case Statement - but is there any way around searching for only one scenario via a Case?
'Create subroutine that will copy and total data from worksheet 1 to worksheet 2
Private Sub VTS()
'Establish variable for CASE to search
Dim ValR As String
'Establish counter array
Dim myarray(1 To 170)
myarray(1) = Worksheets(2).Range("A7").Value
myarray(2) = Worksheets(2).Range("A10").Value
...
ValR = Worksheets(1).Range("B4").Value
Select Case ValR
Case "1A"
Worksheets(2).Range("C7").Copy ' Copy current Total
Worksheets(2).Range("A7").PasteSpecial ' Move to "Previous Total" to sum total
myarray(1) = Worksheets(1).Range("B3").Value - Worksheets(1).Range("B2").Value
If myarray(1) < 0 Then
myarray(1) = 1000000 + myarray(1)
End If
Worksheets(2).Range("B7").Value = myarray(1)
Worksheets(2).Range("C7").Value = Worksheets(2).Range("A7").Value + Worksheets(2).Range("B7").Value
Worksheets(2).Range("C7").Copy
Worksheets(1).Range("B10").PasteSpecial
Case "1B"
Worksheets(2).Range("C10").Copy
Worksheets(2).Range("A10").PasteSpecial
myarray(2) = Worksheets(1).Range("B3").Value - Worksheets(1).Range("B2").Value
If myarray(2) < 0 Then
myarray(2) = 1000000 + myarray(2)
End If
Worksheets(2).Range("B10").Value = myarray(2)
Worksheets(2).Range("C10").Value = Worksheets(2).Range("A10").Value + Worksheets(2).Range("B10").Value
Worksheets(2).Range("C10").Copy
Worksheets(1).Range("B10").PasteSpecial
Case Else
MsgBox "Wrong Model Entered / Model Does Not Exist"
End Select
End Sub
Any suggestions?
THANKS!
You can have the user separate widgets by ";" and then use the following loop:
'widgetString = "widget1;widget2;widget3"
widgets = Split(widgetString, ";")
for w = 0 to ubound(widgets)
thisWidget = widgets(w)
'place all of your code here, with thisWidget being the current widget being evaluated
next w
Related
I have a sheet in which our wholesale team are to enter L09 Part Codes and quickly see how much we have in stock of that item. The problem is that new starters may struggle to learn these part numbers as they don't follow a simple rule. What I did was create an easier code to remember which is simply: "Cable Type" & "Core Size" & "Cut Length", they also have the option to add "Colour" and "Brand" separated by spaces.
Their entered string may look like 6242y 2.5 100, or maybe 6242y 2.5 100 Grey, etc. and so where to look in my mapped table for what they've written depends on how many terms they put in. As you can see from the attached picture I need to select the correct column to look in for their code, and then offset back a few columns to suggest the correct L09 Part Number.
I hope the context makes a bit of sense and helps with the below code. The idea was for a new starter to enter something simple and it be replaced before their very eyes...
If anyone could help me to correct the following it would be greatly appreciated:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim P, Products, S, Search As Range
Dim Column As String
Dim Counter As Integer
Dim Spaces As Long
'On Error Resume Next
Counter = 0
'For top table only
If Target.Column = 1 And Target.Row < 100 Then
'Count spaces
Spaces = UBound(Split(Target, " "), 1)
Select Case Spaces
Case Is = 2
Column = "M"
Case Is = 3
Column = "O"
Case Is = 4
Column = "Q"
End Select
'When string has spaces
If Spaces <> 0 Then
'Set simple code range
Set Search = Sheets("Cherries").Range(Column & 1 & ":" & Column & 10000)
For Each S In Search
If S = Target Then
Target = S.Offset(0, 3 - 2 * Spaces)
End If
Next S
End If
Set Products = Sheets("Order Entry").Range("A3:A99")
For Each P In Products
If P.Value <> "" Then
Counter = Counter + 1
End If
Next P
Sheets("Order Entry").Rows("3:" & Counter + 11).Hidden = False
Sheets("Order Entry").Rows(Counter + 11 & ":99").Hidden = True
End If
End Sub
Unfortunately I'm not sure which line is erroring as no error message is given.
Thank you for your time.
I need to round time to the nearest quarter hour in a word document. I am not very good at coding.
After a fair bit of searching I have found some vba code but it doesn't quite work. The code is:
Sub Time()
Dim num() As String
Dim tod() As String
Dim temp As String
num = Split(Time, ":")
tod = Split(num(2), " ")
If Val(num(1)) < 15 Then
temp = "00"
ElseIf Val(num(1)) < 30 Then
temp = "15"
ElseIf Val(num(1)) < 45 Then
temp = "30"
ElseIf Val(num(1)) < 60 Then
temp = "45"
End If
gettime = num(0) + ":" + temp + ":00 " + tod(1)
End Function
End Sub
When I try to run it I get a message:
"Compile Error: Expected function or variable"
and "Time" on the fifth line of the code is highlighted which I think is where the program stops running.
The rest of the code in the form is as follows:
This module doesn't affect the time rounding issue but I am including it so as not to leave anything out.
Option Explicit
Sub ClusterCheck()
Dim i As Integer, k As Integer, iCluster As Integer, bResult As Boolean
Dim sFieldNameNo As String, sName As String
On Error Resume Next ' If the first formfield is a checkbox, this will bypass the error that Word returns
sName = Selection.FormFields(1).Name ' Get the name of the formfield
bResult = ActiveDocument.FormFields(sName).CheckBox.Value ' Get the result of the current formfield
sFieldNameNo = Number(sName) ' Get generic number
sName = Left(sName, Len(sName) - Len(sFieldNameNo)) ' Get generic name
' Determine how many fields are within the cluster group
iCluster = 1
Do Until ActiveDocument.Bookmarks.Exists(sName & iCluster) = False
iCluster = iCluster + 1
Loop
iCluster = iCluster - 1
' If the check field is true, turn all of the other check fields to false
Application.ScreenUpdating = False
If bResult = True Then
For k = 1 To iCluster
If k <> sFieldNameNo Then ActiveDocument.FormFields(sName & k).Result = False
Next
End If
Application.ScreenUpdating = True
End Sub
This is the Number module:
Option Explicit
Function Number(ByVal sNumber As String) As String
' This module finds the form fields number within the field name
' Loops through the field name until it only has the number
Do Until IsNumeric(sNumber) = True Or sNumber = ""
sNumber = Right(sNumber, Len(sNumber) - 1)
Loop
Number = sNumber
End Function
This is the protection module:
Option Explicit
Sub Protect()
ActiveDocument.Protect Password:="wup13", NoReset:=True, Type:=wdAllowOnlyFormFields
End Sub
Sub Unprotect()
ActiveDocument.Unprotect Password:="wup13"
End Sub
This is the code that activates on opening and closing the document:
Option Explicit
Sub Document_Open()
' Zooms to page width, turns on Hidden Text, and turns off ShowAll and Table Gridlines
With ActiveWindow.View
.Zoom.PageFit = wdPageFitBestFit
.ShowHiddenText = True
.TableGridlines = False
.ShowAll = False
End With
Options.UpdateFieldsAtPrint = False
End Sub
Sub Document_Close()
' Turn on ShowAll and Table Gridlines
With ActiveWindow.View
.ShowAll = True
.TableGridlines = True
End With
Options.UpdateFieldsAtPrint = True
End Sub
That's all the code in the form. I am not great at VBA but am hoping I can solve this issue (with a little help).
DETAILS OF EXTRA DUTY FORM
Persons details
Family name:
Given name(s):
Level:
No.:
Location:
Cost Centre Code:
Time worked
Were any days of the extra duty performed on a designated public/show holiday? Yes 0 No 0
If yes enter holiday date/details:
Time commenced: [Text Form Field]
Date:
Time ceased: [Text Form Field]
Date:
Total Overtime claimed:
Are you a shift worker? Yes 0 No 0
Details of extra duty performed:
Vehicle details
Car: Yes 0 No 0
Motorcycle: Yes 0 No 0
Registration no.:
Fleet no.:
Stationary vehicle hours:
Yes 0 No 0 (only use for stationary duties)
Vehicle odometer start:
Odometer finish:
Total kms:
Client’s details
Company/Organisation name:
Phone no.:
Contact name:
Job no.:
Payment for special services
Was payment received in advance? Yes 0 No 0
If Yes– Amount:
Receipt no.:
Date:
If No– Amount:
Invoice no.:
Date:
I, , certify the above information to be true
(Signature) (Date)
Manager certification (Checked with roster and certified correct)
(Signature) (Date)
The code from vbforums gives me a subscript out of range error when used as recommended.
In the VBA IDE you can get explanations of what keywords do by placing the cursor on a keyword and pressing F1. This will bring up the MS help page for that particular keyword.
In the OP code the main procedure is 'Time'. This will cause problems for VBA because this is the same as the Time keyword so we would effectively be saying
time(time)
and VBA will stop with an error because the second use of time will be interpreted as the sub time and not the VBA time function so you will get the error message 'Argument not optional'.
The code below will provide what the OP has requested.
Option Explicit
Sub test_gettime()
Dim myTime As String
myTime = Now()
Debug.Print myTime
Debug.Print Format(myTime, "hh:mm:ss")
Debug.Print gettime(Format(myTime, "hh:mm:ss"))
' without the format statement we should also get the date
myTime = Now()
Debug.Print
Debug.Print myTime
Debug.Print gettime(myTime)
End Sub
Public Function gettime(this_time As String) As String
Dim myTimeArray() As String
Dim myQuarterHour As String
myTimeArray = Split(this_time, ":")
' Note that myTimeArray has not been converted to numbers
' Comparison of strings works by comparing the ascii values of each character
' in turn until the requested logic is satisfied
Select Case myTimeArray(1)
Case Is < "15"
myQuarterHour = "00"
Case Is < "30"
myQuarterHour = "15"
Case Is < "45"
myQuarterHour = "30"
Case Is < "60"
myQuarterHour = "45"
Case Else
Debug.Print "More than 60 minutes in the hour??"
End Select
gettime = myTimeArray(0) + ":" + myQuarterHour + ":00 "
End Function
I have been trying to get this VBA script to work to automate a task, but I cannot get it to work.
Basically, I have a big task list in excel with multiple columns and over 1000 Rows. It contains the task, who it is assigned to, and if it is open or closed.
In column H is who it assigned to and column N is whether the task is opened or closed.
I am trying to search by last name and if it is OPEN to add one to the counter. The end goal is to get a total count of how many open tasks a person has. Also, some of the cells in column N (task status) has extra text like comments, etc. I am sure that a InStr Function to search for the one word within the Cell would work better, but I cannot figure it out...
here is my code
Sub statuscount()
Dim tasksheet As Worksheet
Dim simons_count As Integer
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" And tasksheet.Cells(x, 14) = "OPEN" Then
simons_count = simons_count + 1
End If
Next x
tasksheet.Range("$O$5").Value = simons_count
End Sub
Thanks for the help!
Using If/And gets tricky in VBA, you're better off nesting two if statements:
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" Then
If InStr(tasksheet.Cells(x, 14).Value, "OPEN") > 0 Then
simons_count = simons_count + 1
End If
End If
Next x
This is a more general function. Insert a module and past the below code in it. Than you can use the function just like any other Excel built-in function
Function LastNamecounter(lastName As String, status As String) As Long
LastNamecounter = 0
Dim tasksheet As Worksheet
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr
If InStr(tasksheet.Cells(i, 8).Value, lastName) <> 0 And InStr(tasksheet.Cells(i, 14).Value, status) <> 0 Then
LastNamecounter = LastNamecounter + 1
End If
Next i
End Function
I'm just starting to learn Excel VBA and I'm running into problems with a particular exercise. Given a column of 20 randomly generated integers between 0 and 100 in a column, I want to write a VBA program that writes in the column next to it "pass" if the number is greater than or equal to 50 and "fail" if the number is less than 50.
My approach involved using a looping function from i = 1 to 20 with an If statement for each cell (i,1) which would write pass or fail in (i,2).
Sub CommandButton1_Click()
'Declare Variables
Dim score As Integer, result As String, i As Integer
'Setup Loop function, If/Then function
For i = 1 To 20
score = Sheet1.Cells(i, 1).Value
If score >= 60 Then result = "pass"
Sheet1.Cells(i, 2).Value = result
Next i
End If
End Sub
Could I get some insight into what I'm doing wrong?
Thanks in advance!
Try something like this...
Sub CommandButton1_Click()
'Declare Variables
Dim score As Integer, result As String, i As Integer
'Setup Loop function, If/Then function
For i = 1 To 20
score = Sheets("Sheet1").Cells(i, 1).Value
If score >= 60 Then
result = "pass"
Else
result = "fail"
End If
Sheets("Sheet1").Cells(i, 2).Value = result
Next i
End Sub
You need to properly specify the worksheet your working with like Sheets("Sheet1").Cells(...
Add an else clause to set result to fail when the value is less than 60. otherwise it never changes after the first 'pass'
Move the End if inside the for loop, immediately after the score check...
The correction with the least amount of changes is the following :
Sub CommandButton1_Click()
'Declare Variables
Dim score As Integer, result As String, i As Integer
'Setup Loop function, If/Then function
For i = 1 To 20
score = Sheet1.Cells(i, 1).Value
If score >= 60 Then
result = "pass"
Sheet1.Cells(i, 2).Value = result
End If
Next i
End If
End Sub
Keep in mind that, in VBA, variables are global to the function; not local to the loop. As it was mentionned, you could also have wrote something like :
result = ""
if score >= 60 then result = "pass"
sheet1....
Hope someone can help with a puzzling problem.
I have an excel worksheet that has a lot of lines that need to be moved to different sheets.
I have a select case statement that sets 3 variables to true or false depending on whether the numbers in the first column match a case statement. This works ok but I now want to add a name to an array if the value is true.
The select case statement is as follows :
While LContinue
If LRow = Lastrow Then
LContinue = False
Else
Select Case Range("A" & LRow).Value
Case 30 To 39
MainSheet = True
'Tabs(0) = "Main"
Case 40 To 49
SecondSheet = True
'Tabs(1) = "Second"
Case 111 To 112
ThirdSheet = True
'Tabs(2) = "Third"
End Select
LRow = LRow + 1
End If
Wend
This is used to see if I need to add the sheet or not. to add the sheets I use the following code :
For i = LBound(Tabs) To UBound(Tabs)
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Tabs(i)
Next i
So what I would like to know is how would I go about adding the sheetnames to the array but only if the value in the select case is true.
Any help would be much appreciated.
Thanks
Why not use worksheet function 'CountIfs'?
It counts on multiple criteria and you do not need any loops so your code will run quicker.
CountIfs(testedRange, ">=30", testedRange, "<=39")
... calculates number of values in 'testedRange' which are >=30 and <=39. If there is at least one then just add your sheet, that's it. No loops, no arrays, no additional variables needed. HTH.
Public Sub test()
Dim testedRange As Range
Dim Lastrow As Long
Lastrow = 10
Set testedRange = ActiveSheet.Range("A1:A" & Lastrow)
With Application.WorksheetFunction
If .CountIfs(testedRange, ">=30", testedRange, "<=39") > 0 Then
ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Main"
End If
If .CountIfs(testedRange, ">=40", testedRange, "<=49") > 0 Then
ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Second"
End If
If .CountIfs(testedRange, ">=111", testedRange, "<=112") > 0 Then
ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Third"
End If
End With
End Sub
Excel VBA is not very flexible when it come to working with actual arrays. But you can work with a collection instead:
SET tabs = new Collection
And then you can add a new value to it whenever you need to (e.g. in the CASE structure):
.
..
...
Case 40 To 49
SecondSheet = True
Tabs.add "Second"
...
..
The values of the collection can be accessed almost in the same way as those of an array:
for j=1 to tabs.count
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = tabs(j)
next j
Edit:
Since the code is re-entrant, i.e. there can be several instances when Range("A" & LRow).Value will be evaluated, we must make sure, that an item is set only once. This can be done easiest with a dictionary (instead of a collection):
Set tabs = CreateObject("Scripting.Dictionary")
Now it is easy to establish, whether a particular page has already been defined before:
..
...
Case 40 To 49
SecondSheet = True
tabs("Second")=1
The page creation loop then looks like this
for each k in tabs.keys
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = k
next k
The loop iterates over the keys only. There is no need to check for duplicate entries as all unique keys will be defined and listed only once!
To do this with an array you would want to:
declare a dynamic array of strings
declare a counter for the number of elements added
set the array's size to the largest value that it could possibly be
assign elements to the array, incrementing the counter for each addition
resize the array using the counter value (or test for empty elements when accessing array)
In code that could translate into something like:
Dim Tabs() as String
Dim counter As Long
...
Redim Tabs(0 to Lastrow)
counter = 0
...
While ...
Select Case .Range("A" & lrow).Value
Case 30 To 39
Mainsheet = True
Tabs(count) = "Main"
...
Case Else
counter = counter - 1
End Select
counter = counter + 1
...
Wend
If Not counter = 0 Then
Redim Preserve Tab(0 to counter - 1)
...
'create worksheets using Tabs(), etc.
...
End If