I am trying to evaluate multiple pieces of information from various columns then output value if the answers meet certain conditions.
I have tried doing an extended select case statement but I know my syntax is wrong or it is not possible to do it the way I am trying to do it. It also throwing the error "type mismatch". Not the full code but a portion.
Dim EJ As String
Dim EL As String
Dim EX As String
Dim EZ As String
Dim EG As String
EJ = GetCellValue(.Cells(i, "EJ"))
EL = GetCellValue(.Cells(i, "EL"))
EX = GetCellValue(.Cells(i, "EX"))
EZ = GetCellValue(.Cells(i, "EF"))
EG = GetCellValue(.Cells(i, "EG"))
Select Case EJ And EL And EX And EZ
Case GetCellValue(.Cells(i, "EJ")) = "YES" And _
GetCellValue(.Cells(i, EL")) "YES" And _
GetCellValue(.Cells(i, "EX")) = "YES" And _
GetCellValue(.Cells(i, "EZ")) = "YES"
.Cells(i, "FI") = Done
I would like to output the word done in a column if the conditions are met.
Select Case is probably not the best choice for this - a regular If...ElseIf...Else would be fine
If EJ="YES" And EL="YES" And EX="YES" And EZ="YES" Then
.Cells(i, "FI") = "Done" '<< added quotes here
Else
'etc etc
End If
This might be significantly different depending on what your other tests look like
The loop can be avoided with Excel Formulas. For example if i is from 2 to 9 :
.Range("FI2:FI9").Formula = "=IF(AND(EJ2=""YES"", EL2=""YES"", EX2=""YES"", EZ2=""YES""), ""Done"", """")"
.Range("FI2:FI9").Value = .Range("FI2:FI9").Value ' optional to convert the formulas to values
You can also accomplish your task using a filter...
With Range("A1").CurrentRegion 'change to meet your range
.AutoFilter
.AutoFilter Field:=140, Criteria1:="YES"
.AutoFilter Field:=142, Criteria1:="YES"
.AutoFilter Field:=154, Criteria1:="YES"
.AutoFilter Field:=156, Criteria1:="YES"
On Error Resume Next
Dim rng As Range
Set rng = Range("Z2:Z" & Cells(Rows.Count, "Z").End(xlUp).Row)
Set rng = rng.Cells.SpecialCells(xlCellTypeVisible)
rng.Offset(, 9).Value = "Done"
End With
Note: Inserting the text in a column for visible rows, without looping, is adapted from an answer by Gary's Student to SO question, 28609977.
Related
I am trying to create a Module that will format an excel spreadsheet for my team at work. There is one column that will contain the word "CPT" and various CPT codes with descriptions.
I need to delete all text (CPT description) after the 5 digit CPT code but alsp keep the word CPT in other cells.
For example: Column S, Row 6 contains only the word "CPT" (not in quotations)
Then Column S, Row 7 contains the text "99217 Observation Care Discharge"
This setup repeats several times throughout Column S.
I would like for Row 6 to stay the same as it is ("CPT") but in Row 7 i only want to keep "99217"
Unfortunately, this is not possible to do by hand as there are several people who will need this macro and our spreadsheets can have this wording repeated hundreds of times in this column with different CPT codes and descriptions.
I have tried various If/Then statements, If/Then/Else
Sub CPTcolumn()
Dim celltxt As String
celltxt = ActiveSheet.Range("S6" & Rows.Count).End(xlUp).Text
Dim LR As Long, i As Long
LR = Range("S6" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
Next i
Else
With Range("S6" & i)
.Value = Left(.Value, InStr(.Value, " "))
End With
Next i
End If
End Sub
When i try to run it I get Various "Compile Errors"
I would do this differently.
Given:
The cell to be modified will be the cell under a cell that contains CPT
in the algorithm below, we look for CPT all caps and only that contents. Easily modified if that is not the case.
Since you write " a five digit code", we need only extract the first five characters.
IF you might have some cells that contain CPT where the cell underneath does not contain a CPT code, then we'd also have to check the contents of the cell beneath to see if it looked like a CPT code.
So we just use the Range.Find method:
Sub CPT()
Dim WS As Worksheet, R As Range, C As Range
Dim sfirstAddress As String
Set WS = Worksheets("sheet4")
With WS.Cells
Set R = .Find(what:="CPT", LookIn:=xlValues, lookat:=xlWhole, _
MatchCase:=True)
If Not R Is Nothing Then
sfirstAddress = R.Address
Set C = R.Offset(1, 0)
C.Value = Left(C.Value, 5)
Do
Set R = .FindNext(R)
If Not R.Address = sfirstAddress Then
Set C = R.Offset(1, 0)
C.Value = Left(C.Value, 5)
End If
Loop Until R.Address = sfirstAddress
End If
End With
End Sub
If this sequence is guaranteed to only be in Column S, we can change
With WS.Cells
to With WS.Columns(19).Cells
and that might speed things up a bit.
You may also speed things up by adding turning off ScreenUpdating and Calculation while this runs.
Your first error will occur here:
ActiveSheet.Range("S6" & Rows.Count).End(xlUp).Text
Because you're trying to retrieve text from the last used range starting .End(xlUp) at Range("S61048576"), which is roughly 58 times the row limit in Excel. You might change Range("S6" & Rows.Count) to Range("S" & Rows.Count)
Your second error will occur here:
LR = Range("S6" & Rows.Count).End(xlUp).Row
Which will be the same error.
The third error will occur here:
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
Next i
You cannot nest half of an If-End If block in a For-Next loop, or vice-versa and you've done both. If you want to iterate and perform an If-End If each iteration, you need to contain the If-End If within the For-Next like
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
'Is the purpose here to do nothing???
Else
With Range("S" & i)
.Value = Left(.Value, InStr(.Value, " "))
End With
End If
Next i
EDIT:
For technical accuracy, your first error would actually be your broken up For-Next and If-End If, as you wouldn't even be able to compile to execute the code to run into the other two errors.
You can simply use the Mid function in the worksheet.
As I understood from your question that you need to separate numbers and put them in other cells, is this true?
To do this, you can write this function in cell R6 like this
=Mid(S6,1,5)
Then press enter and drag the function down and you will find that all the cells containing numbers and texts have been retained numbers in them
I am having several columns with text. Furthermore, I have a column, which is called Replacement text. This columns contains strings that have markers in it, like [1], [2], etc.
I would like to replace the markers with the text that is in the marker`s row.
For example, Here you can find [5] becomes Here you can find b, because [5] is the markers column and in the row of the string b is the value for the marker.
I was thinking of creating a large if-else construct and substitute the text, which is extremely error-prone.
However, I kindly ask you if there is an easier solution?
I appreciate your input!
This answer is highly plagiarised from Thomas Inzina's first version of his answer, but a very simple way of performing the replacement would be:
Sub ReplaceText()
Dim r As Long
Dim c As Long
With ActiveSheet
For r = 3 To .Range("K" & .Rows.Count).End(xlUp).Row
For c = 1 To 10
.Cells(r, "K").Replace "[" & c & "]", .Cells(r, c).Value
Next
Next
End With
End Sub
The above code will attempt to do a substitution using all ten columns.
As Thomas has noted, the following code will only do the substitution if a substitution is necessary and therefore could be an order of magnitude faster, so is undoubtedly a better solution:
Sub ReplaceText()
Dim r As Long
Dim c As Long
With ActiveSheet
For r = 3 To .Range("K" & .Rows.Count).End(xlUp).Row
For c = 1 To 10
If Instr(.Cells(r, "K").Value, "[" & c & "]") > 0 Then
.Cells(r, "K").Replace "[" & c & "]", .Cells(r, c).Value
End If
Next
Next
End With
End Sub
(Many thanks to Thomas for his effort in performing speed tests on the two different methods.)
ReplaceBrackets1: uses RegEx to extract the column number. It takes 15.03 Seconds to processed 100K records.
Sub ReplaceBrackets1()
'http://analystcave.com/excel-regex-tutorial/
Dim c As Range
Dim Match As Object, Matches As Object, regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.Pattern = "\[(.*?)\]"
End With
For Each c In Range("K3", Range("K" & Rows.Count).End(xlUp))
If regex.Test(c.Text) Then
Set Matches = regex.Execute(c.Text)
For Each Match In Matches
c.Replace Match, c.EntireRow.Columns(CInt(Match.SubMatches(0)))
Next Match
End If
Next
End Sub
ReplaceBrackets2: loades the data into arrays, uses RegEx to extract the column number and only writes to the worksheet 1 time. It takes 1.27 seconds to process 100K records.
Sub ReplaceBrackets2()
'http://analystcave.com/excel-regex-tutorial/
Dim x As Long, column As Long
Dim arData, values
Dim Match As Object, Matches As Object, regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.Pattern = "\[(.*?)\]"
End With
values = Range("K3", Range("K" & Rows.Count).End(xlUp))
arData = Range("A3", "L" & UBound(values, 1) + 2)
For x = 1 To UBound(values, 1)
If regex.Test(values(x, 1)) Then
Set Matches = regex.Execute(values(x, 1))
For Each Match In Matches
column = Match.SubMatches(0)
values(x, 1) = arData(x, column)
Next Match
End If
Next
Range("K3", Range("K" & Rows.Count).End(xlUp)) = values
End Sub
After converting ReplaceBrackets1 into a UDF (getReplacedText) I was amazed to find that it only took 2.53 seconds to fill the formula in for a 100K records. I'm not sure way this would be faster that the original. But having that many formulas really slows down the spreadsheet.
getReplacedText: Uses a Static RegEx to parse the data.
Function getReplacedText(ReplacementText As String, Source As Range)
'http://analystcave.com/excel-regex-tutorial/
Dim Match As Object, Matches As Object
Static regex As Object
If regex Is Nothing Then
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.Pattern = "\[(.*?)\]"
End With
End If
If regex.Test(ReplacementText) Then
Set Matches = regex.Execute(ReplacementText)
For Each Match In Matches
ReplacementText = Replace(ReplacementText, Match, Source.Columns(CInt(Match.SubMatches(0))))
Next Match
End If
getReplacedText = ReplacementText
End Function
I have two workbooks, and both shave a list of ALMOST the same items. One of the list has a few extra spaces at the end of its list and it's throwing me completely off.
Public Sub test() 'Imports data into M&R spreadsheet
Dim wbMnR As Workbook
Dim wbMatch As Workbook
Set wbMnR = Workbooks("MnRs.xlsx")
Set wbMatch = Workbooks("Match.xlsm")
Dim myRow As Integer
For i = 1 To 10
myRow = WorksheetFunction.Match(wbMatch.Worksheets(1).Range("a" & CStr(i)), wbMnR.Worksheets(1).Range("A:A"), 0)
Debug.Print myRow
Next i
End Sub
The item list in copy is
"R-01"
"R-02"
"R-03"
"R-04"
the item list in paste is
"R-01 "
"R-03"
"R-02"
"R-04 "
These are just examples I made up and for various reasons I can't input my actual data. I cannot sort my list in the MnR worksheet though since the workbook I was given contains some merge cells and various data which separates specific sections. With the way Match works, I know that using a perfect match of "0" will not work because of the extra space, but using a "1" or "-1" will not work either because my list cannot be sorted.
Try this Select Case statement.
With wbMatch.Worksheets(1)
For i = 1 To 10
myRow = 0
Select Case False
Case IsError(Application.Match(.Range("a" & i), wbMnR.Worksheets(1).Range("A:A"), 0))
myRow = Application.Match(.Range("a" & i), wbMnR.Worksheets(1).Range("A:A"), 0)
Case IsError(Application.Match(.Range("a" & i) & Chr(32), wbMnR.Worksheets(1).Range("A:A"), 0))
myRow = Application.Match(.Range("a" & i) & Chr(32), wbMnR.Worksheets(1).Range("A:A"), 0)
Case Else
'nothing found
End Select
Debug.Print myRow
Next i
End With
If you run into further trouble, that Select Case will be easier to expand upon. To make this more efficient, the most common matches should be at the top of the Case statements.
I am new to both VBA and stackoverflow. So please be patient ;).
I searched for a solution but could not find it.
My problem is as follows:
I have a column (A) with names and then a column (B) where some cells contain an "X" and others do not. I want to know which names have an "X" besides them.
Example:
I want now a string as a result, in one cell.
In this example:
Noah;Jacob;Elijah;Jayden
I got not very far.
For r = 1 To 20
If Cells(r, 2) = "X" Then A = Cells(r, 1) Else
Next
Then "A" is "Noah" and I can write it in a cell, but I want it to find all values and then write them combined, preferable seperated by ; in a cell.
Does anyone have any idea?
Create a string variable, then append your results to that variable based on "X" being in column B. Here's an example of how you could do it:
Sub Foo()
Dim i As Integer
Dim result As String
For i = 1 To 20
If UCase(Cells(i, 2).Value) = "X" Then
result = result & Cells(i, 1).Value & ";"
End If
Next
'// output the result to C1
Range("C1").Value = Left$(result, Len(result) - 1)
End Sub
Excel's native worksheet formulas do not handle concatenating an unknown number of strings together and compensating for the maximum number possible can get messy. A User Defined Function¹ (aka UDF) takes advantage of VBA's ability to process loops through a large number of rows while making numerical or string comparisons 'on-the-fly'.
build_List UDF
Function build_List(rNAMs As Range, rEXs As Range, vEX As Variant, _
Optional delim As String = ";", _
Optional bCS As Boolean = False)
Dim str As String, rw As Long, cl As Long
With rNAMs.Parent
Set rNAMs = Intersect(.UsedRange, rNAMs)
Set rEXs = .Cells(rEXs.Rows(1).Row, rEXs.Columns(1).Column). _
Resize(rNAMs.Rows.Count, rNAMs.Columns.Count)
End With
With rNAMs
For rw = .Rows(1).Row To .Rows(.Rows.Count).Row
For cl = .Columns(1).Row To .Columns(.Columns.Count).Row
If (.Cells(rw, cl).Offset(0, rEXs.Column + (cl - 1) - cl) = vEX And bCS) Or _
(LCase(.Cells(rw, cl).Offset(0, rEXs.Column + (cl - 1) - cl)) = LCase(vEX)) Then _
str = str & .Cells(rw, cl).Value & delim
Next cl
Next rw
End With
build_List = Left(str, Len(str) - Len(delim))
End Function
In D7 (as per image below) as,
=build_List(A:A, B:B, "x")
Applying the build_Lists UDf to your sample data
¹ A User Defined Function (aka UDF) is placed into a standard module code sheet. Tap Alt+F11 and when the VBE opens, immediately use the pull-down menus to Insert ► Module (Alt+I,M). Paste the function code into the new module code sheet titled something like Book1 - Module1 (Code). Tap Alt+Q to return to your worksheet(s).
Mate Juhasz answered the question very nice and simple, but now the answer dissapeared.
Mate wrote:
For r = 1 To 20
If Cells(r, 2) = "X" Then A = A & "; " & Cells(r, 1) Else
Next
And for me that solved it perfectly. Now "A" is a string as I wanted. Thank you so much!
Good Day,
really need some help here, im bad at VBA.
Had created a spreadsheet and recorded a macro to record checkin of staff. However, im having difficulties checking out with the corresponding users based on the name.
Could anyone help me out over here?
Thanks. Had attached the spreadsheet for your ref.
http://www.etechnopia.com/vish/Book1ss.xlsm
After much googling, This is what i did based on mikes solution
Dim name As String
Dim id As Integer
Dim checkin As Date
Dim checkout As Date
name = Range("d6").Value
id = Range("d7").Value
checkin = Now
Range("d10") = checkin
Help anyone? im my very best here.
firstly I recommend to use range names for the important cells of your sheet
D6 EmpName
D7 EmpNo
D10 ClockInTime
D11 ClockOutTime
H5..H11 DataTable
This will enable you to reference them by name instead of hardcoding their addresses (bad bad hardcoding :-/ )
Secondly, your [Button] must serve a dual purpose ... it has to decide if a user is clocked in or out and do different things
a hi-level META code, executed at pressing [Button4] could be
if user clocked in
write current time into ClockOutTime ' remark: this may be superfluous
find DataTable record (EmpName, ClockInTime)
write ClockOutTime into record (EmpName, ClockInTime)
erase EmpName, EmpID, ClockInTime, ClockOutTime
else
write current time into ClockInTime
find first blank record in DataTable
write EmpName, EmpID, ClockInTime into DataTable record
endif
How to decide if a user is clocked in? If many users are using the same sheet at the same time (meaning 5 emps go there, write in their names and clock in) you need to examine DataTable for the first record of EmpNane without a ClockOutTime - if found he/she is in and needs to be clocked out.
more later ...
OK ... sorry was interrupted by Lady Gaga concerto in Vienna/AT
so here's a full code for the button
Sub ButtonPressed()
Dim DB As Range, Idx As Integer
Set DB = Range("DataTable")
If Range("EmpName") = "" Or Range("EmpNo") = "" Then
MsgBox "Enter your name and ID before pressing the button", vbCritical + vbOKOnly, "missing input"
Exit Sub
End If
Idx = UserClockedIn()
If Idx <> 0 Then
DB(Idx, 4) = Date + Time()
DB(Idx, 5).Formula = "=" & DB(Idx, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) & "-" & DB(Idx, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
DB(Idx, 5).NumberFormat = "[hh]:mm"
Range("EmpName") = ""
Range("EmpNo") = ""
Else
Idx = 2
Do While DB(Idx, 1) <> ""
Idx = Idx + 1
Loop
DB(Idx, 1) = Range("EmpName")
DB(Idx, 2) = Range("EmpNo")
DB(Idx, 3) = Date + Time()
End If
End Sub
Private Function UserClockedIn() As Integer
Dim DB As Range, Idx As Integer
Set DB = Range("DataTable")
UserClockedIn = 0
Idx = 2
Do While DB(Idx, 1) <> ""
If DB(Idx, 1) = Range("EmpName") And DB(Idx, 2) = Range("EmpNo") And DB(Idx, 4) = "" Then
UserClockedIn = Idx
Exit Function
End If
Idx = Idx + 1
Loop
End Function
#user502908: I have not documented it because I want you to find out exactly what it does and by that have a quick start into Excel-VBA :-) It doesn't do too much and there are some basic thechniques you will apply again & again if you go into VBA ... try to populate ranges "ClockInTime" and "ClockOutTime" :-)))
Book1ssNew.xlsm
have fun
I tried another simpler method which i could cope with
Sub yes()
Dim findId As Integer
Dim FirstAddress As String
Dim FindString As Integer
Dim Rng As Range
FindString = Range("d7").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("F1:J100")
Set Rng = .find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
FirstAddress = Rng.Address
Rng.Offset(0, 2).Value = Now()
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub
Search entire spreadsheet given id, when id found, to indicate dynamically the checkin timing.