I have always to delete thirty values from a column, I have managed to "create" a code, that does that, however when one of the values is not found, the code bugs and deletes the entire column.
I'm looking for some piece of code that ckecks if the values exists, if not it just skips it.
I'd rather not use that kinda code that prompts a text box to input the value, since I have to delete 30 of them, which have different names.
While writing this question I tried this so far, however the codes keeps asking for the next object, which requires me to click at lest 29 times
Sub IfContains()
If InStr(ActiveCell.Value, "string1") > 0 Then
ActiveCell.Delete = True
Else
If InStr(ActiveCell.Value, "string2") > 0 Then
ActiveCellDelete = True
End If
End If
End Sub
This might be a better approach. You have only one string to configure, delimited by the tilde (~) character. Then split that into an array of individual values and use a loop to look for every value of the array.
Sub IfContains()
Dim x As Integer
Dim values As Variant
values = "string1~string2~string3" ' using a tilde (~) to separate the values
values = Split(values, "~") ' make an array of individual values
For x = 0 To UBound(values)
If InStr(1, ActiveCell.Value, values(x)) > 0 Then ActiveCell.Delete
Next
End Sub
Related
First time posting a question here. Excited to be a part of the community!
I have a sticky situation where converting data for a client has me stumped.
I need to find a way to not only split a cell by multiple Delimiters, but some data points need to be removed as well. In this situation, we're talking about a list of tenants and any additional occupants on a lease.
This is how the data was exported and in its current state
You'll see that there is at least one common delimiter I can use here. The " : " would allow me to simply split the names, but the real issue here is that the tenant names listed under the data points "son" or "daughter" need to be removed. On the other hand, the tenants listed as "resident" or "tenant" must be kept.
An example of how I'd want this to look
You'll see that the names are split and only the names listed under "tenant" or "resident" are kept and the others are dropped.
I've tried to find and replace the terms I want to keep with a simple character I can use to split, but the issue is that there isn't a consistent sequence for me to use this. I've been looking for a split VBA function that would work as well, but haven't had any luck.
Thoughts here would be welcome!
I think this function is probably an over-kill. But it does what you want.
Function SplitCellValue(ByVal CellVal As String) As String
'137
Const Qualifiers As String = "tenant,resident"
Dim Fun() As String ' function return array
Dim n As Integer ' index of Fun()
Dim Qword() As String ' split Qualifiers
Dim q As Integer ' index of Qword
Dim Sp() As String ' split array
Dim i As Integer ' index of Sp()
Dim Skip As Boolean ' True if entry doesn't qualify
Dim Append As Boolean ' True to append unqualified entry to previous
If Len(CellVal) Then ' skip blank CellVal
Qword = Split(Qualifiers, ",")
Sp = Split(Trim(CellVal), ",")
ReDim Fun(1 To UBound(Sp) + 1)
For i = 0 To UBound(Sp)
If InStr(Sp(i), ":") Then
For q = LBound(Qword) To UBound(Qword)
Skip = CBool(InStr(1, Sp(i), Qword(q), vbTextCompare))
If Skip Then Exit For
Next q
If Skip Then
n = n + 1
Fun(n) = Trim(Sp(i))
Append = True
Else
Append = False
End If
Else
If n = 0 Then
' preserve unqualified, leading entry
n = 1
Append = True
End If
If Append Then
If Len(Fun(n)) Then Fun(n) = Fun(n) & ", "
Fun(n) = Fun(n) & Trim(Sp(i))
End If
End If
Next i
End If
If i Then
ReDim Preserve Fun(1 To n)
SplitCellValue = Join(Fun, ", ")
End If
End Function
List all the qualifiers in the constant Qualifiers. Everything else will be rejected. Qualifiers only qualify an element if they appear in the same comma-separated element as a colon. (I probably might as well have combined the two but I didn't.)
You can use this function in VBA with a call like this one.
Private Sub Test_SplitCellValue()
Dim R As Integer
For R = 2 To 5
Debug.Print i, SplitCellValue(Cells(R, 1).Value)
Next R
End Sub
or as a UDF, called like, =SplitCellValue(A2). Install in a standard code module for this use.
The over-kill is in what the function can do that is probably not needed. (1) A blank cell will return a blank. (2) A non-blank cell will return its original value if no colon is found in it. (3) Anything before a first element with a colon in it will be included in the return. (4) blanks in the original are removed and replaced by blanks following commas which themselves are removed and then placed between qualifying elements. All of this takes a lot of code that may have to be revised if your data or expectations defy my anticipation.
So after some trial and error, this was much simpler than I was thinking. There were two different instances of ", " & "," (one had a space behind) being used in different manners.
I was able to find and replace for the instance of comma with a space, keeping the detail I needed intact, while delimiting the "," without a space.
Thanks!
I have a formula from a previous question that's working fine. It lists the unique values of dynamic column A to column B, starting from B2. Often Column A has several thousand values, then the processing takes a long time. Increasing calculation threads hasn't saved much time. I'm looking for a better method or formula that could save me a lot of time.
=IFERROR(INDEX(A:A;AGGREGATE(15;6;ROW($A$2:INDEX(A:A;MATCH("zzz";A:A)))/(COUNTIF($B$1:B1;$A$2:INDEX(A:A;MATCH("zzz";A:A)))=0);1));"")
As mentioned in the comments to your question, using the new, "pre-official" UNIQUE function or a pivot table may be the easiest and fastest way to get the unique values. However, if you would like to use a VBA function that does not require pressing a button or using a newer version of Excel, you may want to try the VBA function "GetUniques" described below.
This is a sample of how the function could be used:
To use the function, one must do 3 things:
Add a reference to mscorlib.dll in the VBA Editor (reason explained below)
Add the code for the VBA function itself (preferably in a module of its own)
Add code to handle the workbook's SheetCalculate event (reason explained below)
The reason for the mscorlib.dll was to use the "ArrayList" class (which made life easier than using the Collection class) because it comes with a sorting method (otherwise, we would have to implement a QuickSort procedure). To avoid late binding, I added the reference to this library (located at "C:\Windows\Microsoft.NET\Framework\v4.0.30319" on my machine) in the VBA Editor. You may want to go to the link below for more info on how to use this class:
https://excelmacromastery.com/vba-arraylist/
The VBA function actually writes values outside of the formula cell from which it is called. Since Excel does not take too well to this, a workaround was needed. I tried to use the "Application.Evaluate" method as a workaround, which is suggested in various places, but it did not work for me for some reason. Therefore, I was forced to use the SheetCalculate event (as recommended in other places). In short, the function itself does not write values outside of the caller cell but leaves a "request" for it in a "quasi-queue" that is then processed whilst Excel handles the SheetCalculate event; this event will be triggered after the VBA function has finished executing. This function writes the first value within the formula cell itself and the rest of the values directly below the formula cell.
The "GetUniques" function takes two arguments:
The range with the values to process (I recommend sending the entire column as the range, unless there is a header)
An optional "data type" string that allows the function to convert the values to the right data type (to avoid errors when comparing values of different types)
The optional "data type" value can be "L" (meaning "long integers"), "D" (meaning "dates"), "F" (meaning floating-point doubles), "S" (meaning case-insensitive strings), or "S2" (meaning "case-sensitive strings"). Values that cannot be converted will simply be ignored. If no "data type" value is provided, no type conversion is attempted, but the function may error out if an invalid comparison between different data types is attempted.
The code for the VBA function, called "GetUniques", appears below. This code can be copy-pasted to a module of its own:
Option Explicit
'This is the "commands queue" that is filled up in this module and is "executed" during the SheetCalculate event
Public ExtraCalcCommands As New Collection
Function GetUniques(ByVal dataRange As Range, Optional ByVal dataType As String = "") As Variant
'Attempt to remove unused cells from the data range to make it smaller
Dim dataRng As Range
Set dataRng = Application.Intersect(dataRange, dataRange.Worksheet.UsedRange)
'If the range is completely empty, simply exit
If dataRng Is Nothing Then
GetUniques = ""
Exit Function
End If
'Read in all the data values from the range
Dim values As Variant: values = dataRng.value
'If the values do not form an array, it is a single value, so just return it
If Not IsArray(values) Then
GetUniques = values
Exit Function
End If
'Get the 2-dimensional array's bounds
Dim arrLb As Long: arrLb = LBound(values, 1)
Dim arrUb As Long: arrUb = UBound(values, 1)
Dim index2 As Long: index2 = LBound(values, 2) 'In the 2nd dimension, we only
' care about the first column
'Remember the original number of values
Dim arrCount As Long: arrCount = arrUb - arrLb + 1
'Since [values] is an array, we know that arrCount >= 2
Dim i As Long
'Using ArrayList based on ideas from https://excelmacromastery.com/vba-arraylist
'Copy the values to an ArrayList object, discarding blank values and values
' that cannot be converted to the desired data type (if one was specified)
Dim valuesList As New ArrayList
Dim arrValue As Variant
For i = arrLb To arrUb
arrValue = values(i, index2)
If (arrValue & "") = "" Then
'Skip blank values
ElseIf Not CouldConvert(arrValue, dataType) Then
'This conversion may be necessary to ensure that the values can be compared against each other during the sort
Else
valuesList.Add arrValue
End If
Next
Dim valuesCount As Long: valuesCount = valuesList.Count
'Sort the list to easily remove adjacent duplicates
If Not CouldSort(valuesList) Then
GetUniques = "#ERROR: Could not sort - consider using the data type argument"
Exit Function
End If
'Remove duplicates (which are now adjacent due to the sort)
Dim previous As Variant
If valuesCount > 0 Then previous = valuesList.Item(0)
Dim current As Variant
i = 1
Do While i < valuesCount
current = valuesList.Item(i)
If ValuesMatch(current, previous, dataType) Then 'Remove duplicates
valuesList.RemoveAt i
valuesCount = valuesCount - 1
Else
previous = current
i = i + 1
End If
Loop
'Replace the removed items with empty strings at the end of the list
' This is to get back to the original number of values
For i = 1 To arrCount - valuesCount
valuesList.Add ""
Next
'Return the first value as the function result
GetUniques = valuesList.Item(0) 'We know valuesList.Count=arrCount>=2
'Write the rest of the values below
valuesList.RemoveAt 0
WriteArrayTo valuesList, Application.Caller.Offset(1, 0)
End Function
Private Function CouldSort(ByRef valuesList As ArrayList)
On Error Resume Next
valuesList.Sort
CouldSort = Err.Number = 0
End Function
Private Function CouldConvert(ByRef value As Variant, ByVal dataType As String)
CouldConvert = True
If dataType = "" Then Exit Function
On Error Resume Next
Select Case dataType
Case "L": value = CLng(value)
Case "F": value = CDbl(value)
Case "D": value = CDate(value)
Case "S", "S2": value = value & ""
End Select
CouldConvert = Err.Number = 0
End Function
Private Function ValuesMatch(ByVal v1 As Variant, ByVal v2 As Variant, ByVal dataType As String) As Boolean
On Error Resume Next
Select Case dataType
Case "S": ValuesMatch = StrComp(v1, v2, vbTextCompare) = 0
Case "S2": ValuesMatch = StrComp(v1, v2, vbBinaryCompare) = 0
Case Else: ValuesMatch = v1 = v2
End Select
If Err.Number <> 0 Then ValuesMatch = False
End Function
Private Sub WriteArrayTo(ByVal list As ArrayList, ByRef destination As Range)
'This procedure does not do the actual writing but saves the "command" to do the writing in a "queue";
' this "commands queue" will be executed in the SheetCalculate event;
'We cannot write to cells outside the UDF's formula whilst the function is being calculated
' because of Excel restrictions; that is why we must postpone the writing for later
Dim coll As New Collection
coll.Add "DoWriteList" 'Name of the procedure to execute
coll.Add destination '1st argument used by the procedure
coll.Add list '2nd argument used by the procedure
ExtraCalcCommands.Add coll
End Sub
This code must be added in the workbook's "ThisWorkbook" module in order to handle the SheetCalculate event:
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim i&
Do While ExtraCalcCommands.Count > 0
Dim cmdColl As Collection: Set cmdColl = ExtraCalcCommands.Item(1)
Select Case cmdColl.Item(1)
Case "DoWriteList": DoWriteList cmdColl.Item(2), cmdColl.Item(3)
'Other procedure names could go here in future
End Select
'Remove the processed "command" from the queue
ExtraCalcCommands.Remove 1
Loop
End Sub
Private Sub DoWriteList(ByRef destination As Range, ByVal list As ArrayList)
destination.Resize(list.Count, 1).value = WorksheetFunction.Transpose(list.ToArray)
End Sub
I hope the above is of some help, and, if so, I hope it is a speed improvement on the original IFERROR formula. I also hope the SheetCalculate event handler does not pose issues in dense workbooks with many formulas and calculations.
I am displaying a listbox from which the user may select lines.
The code then reads from the spreadsheet cells associated with that list item and set a number of text variables. These are then concatenated and stored in to an array.
Finally, the array is read and the strings copied to the Clipboard.
However, when I try to use CTRL-v to paste the values in to an email/text file, no text is entered (the Clipboard appears to be empty).
Below is the salient code...
NB. Code based on a 3-line selection from the Listbox
Dim LinesOfData() As String
'Other code that doesn't have direct relevance.. builds the strings
Set MyData = New DataObject
MyData.Clear
Dim record As Variant
Dim Indentifier As String
j = 0
For Each record In LinesOfData
Indentifier = "FormatID" & CStr(j)
Debug.Print record
MyData.SetText record, Indentifier
MyData.PutInClipboard
MyData.GetFromClipboard
'
' Test code only
'
If j = 0 Then 'First pass, only 1 record to check
S = MyData.GetText("FormatID0")
Debug.Print S 'Shows correct value
ElseIf j = 1 Then '2nd pass, 2 records to check
S = MyData.GetText("FormatID0")
Debug.Print S 'Shows correct value
S = MyData.GetText("FormatID1")
Debug.Print S 'Shows correct value
ElseIf j = 2 Then
S = MyData.GetText("FormatID0")
Debug.Print S 'Shows correct value
S = MyData.GetText("FormatID1")
Debug.Print S 'Shows correct value
S = MyData.GetText("FormatID2")
Debug.Print S 'Shows correct value
End If
' If I go and try to paste in another appl'n at this point, nothing!
j = j + 1
Next record
' End code
Now it doesn't matter if I exit the particular userform, or the application, I still have an empty Clipboard (despite being able to read the data from the Clipboard within the code).
As you might expect, I kept looking for an asnwer and indeed I found it.
THIS IS A WINDOWS BUG!
Apparently, this occurs when you have 2 or more Explorer windows open (since Windows 8) and I had just that the entire time I was testing. Once I had only the one window open, viola! it worked.
Not sure if this is allowed. but here is the thread that alerted me, with code to achieve the result using API calls, provided by, Debaser at the end of the post.
https://chandoo.org/forum/threads/clipboard-copy-vba-code-not-working-in-windows-10.37126/
Hopefully, others will find this useful.
The code returning an error is the first line of the following:
While StrComp(selectedRecipe, dataSheet.Cells(i, 1)) <> 0
recipeRow = recipeRow + 1
i = i + 1
Wend
The debug I'm getting has issues with the While statement line itself. This code is contained under an OK Button click event on a userform, with selectedRecipe defined as a public string variable in the main worksheet sub. "i" is defined as an integer in this private sub. Basically the code is to find which row of the sheet holds the string value contained in selectedRecipe after selectedRecipe is selected from a drop-down combo box (selectedRecipe returns correctly and has no issues associated with it). I assume I need to have some sort of "converting" command in front of "dataSheet.Cells(i,1)" to reinforce the cell value as a string, but am not sure. Thanks!
1) Make sure dataSheet is actually set to a valid sheet. 2) as Comintern said, you need to begin at 1 as Excel is 1 based not zero based. 3) You need to make sure you don't overflow the number of rows:
Public Sub CheckRecipe()
Dim selectedRecipe As String
Dim i As Long
selectedRecipe = "Test"
i = 1
While StrComp(selectedRecipe, ThisWorkbook.ActiveSheet.Cells(i, 1).Value) <> 0 _
And i < ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
i = i + 1
Wend
End Sub
I am trying to force a specific range of cells in Excel to auto capitalize a specific phrase.
For example: We commonly enter type of aircraft such as Saab, Citation, etc. I have a VB script to force Proper Case but there are other times that we abbreviate such as DA20, CJ3, etc.
What I would like (if this is even possible) is for the long names (if used) to remain Proper Case however if they type specific phrases, I would like it to ignore the script and allow it as entered OR auto capital the first two characters.
Diamond or DA20 would be acceptable
Citation or CJ3 would be acceptable
What I don't want is someone that is lazy to type
citation or cj3
diamond or da20
Is this possible? I would be willing to create a whitelist of sorts of all the abbreviations if necessary that would be allowed.
I was hoping some sort "IF" statement may work on the VBA script but I am unsure how to write this.
You can trigger auto-updating of certain ranges using the Worksheet Change event. This requires the user to partially enter the desired input (they need to exit the cell for it to trigger) and will auto-fill the remainder. For instance:
Public boolChanging As Boolean
Private Sub Worksheet_Change(ByVal rng As Range)
Dim strAutoFinish As String, iStartPos As Integer
'Exit unless updates occur when and where you want
If boolChanging Or rng.Row < 1 Or rng.Column <> 1 Or rng.Columns.Count > 1 Or rng.Rows.Count > 1 Then Exit Sub
If rng = "" Then Exit Sub 'This needs to be here in case multiple cells are editted
boolChanging = True
strAutoFinish = ";DA20;Diamond;CJ3;Citation;..."
iStartPos = InStr(UCase(strAutoFinish), ";" & UCase(rng))
If iStartPos > 0 Then
rng = Mid(strAutoFinish, iStartPos + 1, InStr(iStartPos + 1, strAutoFinish, ";") - iStartPos - 1)
Else 'Leave this part if you want it to delete invalid entries
rng = ""
End If
boolChanging = False
End Sub