The goal is to get unused values in the textbox, currently i get all of them, se below
This is what I´m trying to get..
..and finally(don't know how to formulate the question yet) this..
My code so far..
It fails to recognize any matches on line 21 (If x = y Then match = True)
Option Explicit
Sub Resources()
Application.ScreenUpdating = False
Dim Arr As Variant
Arr = Range("A2:A10").Value
Dim varr As Variant
varr = Application.Transpose(ExtractNumbers(Range("C2:E10")))
ActiveSheet.TextBox1.Text = "Unused values"
Dim i As Integer
i = 1
Dim x As Variant, y As Variant, z As Variant
Dim match As Boolean
For Each x In Arr
match = False
For Each y In varr
If x = y Then match = True
Next y
If Not match And x > 0 Then
ActiveSheet.TextBox1.Text = ActiveSheet.TextBox1.Text & Chr(10) & x
End If
i = i + 1
Next
Application.ScreenUpdating = True
End Sub
Public Function ExtractNumbers(Target As Range) As Variant
Dim regEx As Object
Set regEx = CreateObject("vbscript.regexp")
Dim regExMatches As Object, regExMatch As Object
Dim Result As String
Dim Cell As Range
For Each Cell In Target
If Cell.Value <> vbNullString Then
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[0-9]+"
End With
Set regExMatches = regEx.Execute(Cell.Value)
For Each regExMatch In regExMatches
Result = Result & regExMatch & ", "
Next regExMatch
End If
Next Cell
ExtractNumbers = Split(Left$(Result, Len(Result) - 1), ", ")
End Function
Collect the values into a vbLF delimited list before depositing them onto the worksheet.
Option Explicit
Sub resources()
Dim i As Long, str As String
With Worksheets("sheet6")
'collect the missing
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If Not CBool(Application.CountIf(.Range("C:E"), .Cells(i, "A").Value)) Then
str = Chr(10) & .Cells(i, "A").Value & Space(1) & .Cells(i, "B").Value & str
End If
Next i
'put results in merged cell
If CBool(Len(str)) Then
str = "unused values" & str
.Range("F:F").UnMerge
.Cells(1, "F").Resize(UBound(Split(str, Chr(10))) + 1, 1).Merge
.Cells(1, "F").WrapText = True
.Cells(1, "F") = str
End If
End With
End Sub
Related
If I have values in cell c3= 2,4,6,8,12,14,18,23,35,78,101,38,30,205,2,101
In This two values are duplicate which is { 2,101 }
I want notification as and when enter any value twice, three-time , forth time, etc in that cell i should come to know which value is repeated. Duplicate values can be shown in adjacent cell D3,
Try this
Sub Test_CheckDups_UDF()
With Range("A1")
.Value = "2,4,6,8,12,14,18,23,35,78,101,38,30,205,2,101"
.Offset(, 1).Value = CheckDups(.Value)
End With
End Sub
Function CheckDups(s As String) As String
Dim a, dic As Object, i As Long
Set dic = CreateObject("scripting.dictionary")
a = Split(s, ",")
For i = LBound(a) To UBound(a)
If dic.Exists(a(i)) = True Then CheckDups = CheckDups & IIf(CheckDups = Empty, "", ",") & a(i) Else dic.Add a(i), 1
Next i
End Function
Here's a code that will highlight the duplicates within the same cell. Tweak it so as to suit your needs
Sub Highlight_Duplicates_Within_Cell()
Dim s, sp, k, c As Range, t As String, f As Boolean, n As Long
For Each c In Range("C3:C13")
c.Font.Color = vbBlack
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
sp = Split(c.Value, ",")
For Each s In sp
If Not .Exists(s) Then .Add s, 1 Else .Item(s) = .Item(s) + 1
Next s
For Each k In .Keys
t = "," & k & ","
f = False
n = InStr(1, "," & c.Value & ",", t, vbTextCompare)
Do While n And .Item(k) > 1
If f Then
c.Characters(n, Len(t) - 2).Font.Color = vbRed
End If
n = InStr(n + Len(k), "," & c.Value & ",", t, vbTextCompare)
f = True
Loop
Next k
End With
Next c
End Sub
Try this version too using Regex
Sub Highlight_Duplicates2()
Dim mtch As Object, mtch2 As Object, m As Object, mm As Object, c As Range, txt As String, i As Long
For Each c In Range("C3:C13")
With CreateObject("VBScript.RegExp")
.Global = True
txt = c.Value
.Pattern = " *(\w+)"
Set mtch = .Execute(txt)
For Each m In mtch
.Pattern = "\b" & m.submatches(0) & "\b"
Set mtch2 = .Execute(txt)
If mtch2.Count > 1 Then
For i = 1 To .Execute(txt).Count - 1
Set mm = mtch2(i)
With c.Characters(mm.firstindex + 1, mm.length).Font
.Color = vbRed: .Bold = True
End With
Mid$(txt, mm.firstindex + 1, mm.length) = Space(mm.length)
Next i
End If
Next m
End With
Next c
End Sub
This does not meet your request of trapping duplicates while typing. However to process a comma-separated string (once entered) consider the following user defined function:
Public Function duplist(s As String) As String
Dim s2 As String, arr
Dim kount As Long, i As Long, j As Long
arr = Split(s, ",")
For i = 0 To UBound(arr)
kount = 0
v = arr(i)
For j = 0 To i
If v = arr(j) Then kount = kount + 1
Next j
If kount = 2 Then s2 = s2 & "," & v
Next i
duplist = Mid(s2, 2)
End Function
SO I have a list of words ( they are 250ish medications in my Settings sheet ) , and I want to use vba to find those specific words in Column D of another sheet and color them magenta. Column D has 105 cells that are full of text.
text I want to search:
list of meds:
what I want it to look like:
below is what iv gathered from other resources but I just cant get it to work! please let me know if you have any suggestions!
also it kinda has to work with mac and windows excel
Sub ColorWords3()
Dim Position As Long, Cell As Range, W As Variant, Words As Variant, Txt As String, druglastcol As Variant, drugs As Variant
druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row
'Words = Array("TEXT", "WORD", "THEN")
Words = Application.Transpose(Sheets("Settings").Range("A4:A" & druglastcol).Text)
For Each Cell In Columns("D").SpecialCells(xlConstants)
Txt = " " & UCase(Cell.Value) & " "
For Each W In Words
Position = InStr(Txt, W)
Do While Position > 0
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & W & "[!A-Z0-9]" Then
With Cell.Characters(Position - 1, Len(W)).Font
.Bold = True
.Color = vbRed
End With
End If
Position = InStr(Position + 1, Txt, W)
Loop
Next
Next
End Sub
Like is case-sensitive, so you need to upper-case your drug names to match your upper-cased blocks of text.
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & UCase(W) & "[!A-Z0-9]" Then
Using Like gets a bit clunky so here's a RegExp-based approach:
EDIT - added a working Like/InStr version...
Sub ColorWords()
Dim Cell As Range, W, Words, matches As Collection, m
With Sheets("Settings")
Words = Application.Transpose(.Range(.Range("A4"), _
.Cells(.Rows.Count, 1).End(xlUp)))
End With
For Each Cell In ActiveSheet.Columns("D").SpecialCells(xlConstants)
For Each W In Words
'Set matches = AllMatchesRegEx(Cell.Text, W) 'windows only
Set matches = AllMatchesInStr(Cell.Text, W) 'windows+mac
For Each m In matches
Debug.Print Cell.Address, W, m
With Cell.Characters(m, Len(W)).Font
.Bold = True
.Color = vbMagenta
End With
Next m
Next
Next
End Sub
Function AllMatchesInStr(ByVal textToSearch As String, searchTerm)
Const OUT As String = "[!A-Z0-9]"
Dim rv As New Collection, pos As Long, start As Long
Dim next2 As String, next1 As String
textToSearch = UCase(" " & textToSearch & " ")
start = 1
pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
Do While pos > 0
If Mid(textToSearch, pos - 1, 1) Like OUT Then
next2 = Mid(textToSearch, pos + Len(searchTerm), 2)
next1 = Left(next2, 1)
'Handle possible s at end of search term
If next1 Like OUT Or (next2 Like "S" & OUT) Then
rv.Add pos - 1
End If
End If
start = pos + 1
pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
Loop
Set AllMatchesInStr = rv
End Function
Function AllMatchesRegEx(textToSearch As String, searchTerm)
Dim rv As New Collection, matches, m
Static reg As Object
If reg Is Nothing Then
Set reg = CreateObject("VBScript.RegExp")
reg.Global = True
reg.IgnoreCase = True
End If
reg.Pattern = "\b" & searchTerm & "s?\b" 'Allow for simple plural form,
'flank with word boundaries
Set matches = reg.Execute(textToSearch)
For Each m In matches
rv.Add m.firstindex + 1 'firstindex is zero-based
Next m
Set AllMatchesRegEx = rv
End Function
There is a mistake in your code:
Words = Application.Transpose(Sheets("Settings").Range("A4:A" & Dr).Text)
what is Dr?
Also don't do this:
druglastcol = Sheets("Settings").Range("A4:A" & Rows.Count).End(xlDown).Row
Do this instead:
druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row
The reason we do it this way is the method you have used will stop if there is a blank row in the data, the method i have posted comes from the bottom up so will always grab the true last row.
Try
Sub test()
Dim Ws As Worksheet
Dim s As String
Dim vDB
Dim i As Long
'Application.ScreenUpdating = False
Set Ws = Sheets("Settings")
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
For i = 1 To UBound(vDB, 1)
s = vDB(i, 1)
setCharacterColor s
Next i
'Application.ScreenUpdating = True
End Sub
Sub setCharacterColor(strPattern As String)
Dim mCol As Object 'MatchCollection
Dim Ws As Worksheet
Dim rngDB As Range, rng As Range
Dim s As String
Dim i As Integer, Ln As Integer
Set Ws = Sheets("Facts")
Set rngDB = Ws.Range("d1", Ws.Range("d" & Rows.Count).End(xlUp))
For Each rng In rngDB
s = rng.Value
Set mCol = GetRegEx(s, strPattern)
If Not mCol Is Nothing Then
For i = 0 To mCol.Count - 1
c = mCol.Item(i).FirstIndex + 1
Ln = mCol.Item(i).Length
With rng.Characters(c, Ln).Font
.Bold = True
.Color = vbMagenta
End With
Next i
End If
Next
End Sub
Function GetRegEx(StrInput As String, strPattern As String) As Object
Dim RegEx As Object 'New RegExp
Set RegEx = CreateObject("VBScript.RegExp") 'New RegExp
With RegEx
.Global = True
.IgnoreCase = False
.MultiLine = True
.Pattern = strPattern
End With
If RegEx.test(StrInput) Then
Set GetRegEx = RegEx.Execute(StrInput)
End If
End Function
If your use Mac then try below.
Sub test()
Dim Ws As Worksheet, WsColor As Worksheet
Dim rngDB As Range, rng As Range
Dim s As String
Dim vDB, vR
Dim i As Long, Ln As Integer
Dim j As Index
Dim st, et
Application.ScreenUpdating = False
st = Timer
Set Ws = Sheets("Settings")
Set WsColor = Sheets("Facts")
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
With WsColor
Set rngDB = .Range("d1", .Range("d" & Rows.Count).End(xlUp))
End With
For Each rng In rngDB
For i = 1 To UBound(vDB, 1)
Ln = Len(vDB(i, 1)) 'String Length
vR = getItem(rng, vDB(i, 1)) 'string startedIndex
If IsArray(vR) And Not IsEmpty(vR) Then
For j = 1 To UBound(vR)
With rng.Characters(vR(j), Ln).Font
.Bold = True
.Color = vbMagenta
End With
Next j
End If
Next i
Next rng
Application.ScreenUpdating = True
et = Timer
Debug.Print et - st
End Sub
Function getItem(rng As Range, v As Variant) As Variant
Dim vR()
Dim k As Integer, s As Integer, n As Index
Dim str As String
str = rng.Text
s = 1
Do
n = InStr(s, str, v)
If n > 0 Then
k = k + 1
ReDim Preserve vR(1 To k)
vR(k) = n
End If
s = n + Len(v)
DoEvents
Loop While n > 0
If k Then
getItem = vR
Else
getItem = Empty
End If
End Function
If I have the below info all contained in a single cell and I want to split it into separate cells. I understand how to use the space as a delimiter but in this case, the name also has spaces and I want the name to stay together in a single cell. To further complicate the matter, the name is not always just first and last, it can also include middle so is not always a standard two names.
2172571122 Jane Doe 3143332222 John Doe
2172242237 Mary Mixer 2223334444 Mike M Martin
Want it to end up looking like this:
Cell 1 = 2172242237
Cell 2 = Mary Mixer
Cell 3 = 2223334444
Cell 4 = Mike M Martin
Any suggestions?
This regex based function alternates each split between numbers and text (words).
Option Explicit
Function customSplit(str As String, _
Optional ndx As Integer = 1) As Variant
Static rgx As Object, cmat As Object
Set rgx = CreateObject("VBScript.RegExp")
With rgx
.Global = True
.MultiLine = True
.IgnoreCase = True
If CBool(ndx Mod 2) Then
.Pattern = "[0-9]{10}"
ndx = (ndx + 1) \ 2
Else
.Pattern = "[A-Z]{1,9}\s[A-Z]{1,9}[\s[A-Z]{1,9}]?"
ndx = ndx \ 2
End If
If .test(str) Then
Set cmat = .Execute(str)
If ndx <= cmat.Count Then
customSplit = cmat.Item(ndx - 1)
End If
End If
End With
End Function
You could try:
Option Explicit
Sub test()
Dim strToSplit As String, strImport As String
Dim arrwords As Variant
Dim i As Long, counter As Long
With ThisWorkbook.Worksheets("Sheet1")
strToSplit = .Range("A1").Value
arrwords = Split(strToSplit, " ")
counter = 1
For i = LBound(arrwords) To UBound(arrwords)
If IsNumeric(arrwords(i)) = True Then
strImport = arrwords(i)
.Cells(3, counter).Value = strImport
counter = counter + 1
ElseIf Not IsNumeric(arrwords(i)) = True Then
If Not IsNumeric(.Cells(3, counter - 1).Value) Then
strImport = .Cells(3, counter - 1) & " " & arrwords(i)
.Cells(3, counter - 1).Value = strImport
counter = counter
Else
strImport = arrwords(i)
.Cells(3, counter).Value = strImport
counter = counter + 1
End If
End If
Next
End With
End Sub
Results look like this:
I have a few ideas on what you could do.
1) Read a Line
Do a split(line, " ") and loop through the indecies while performing a isNumeric() on each split value. If not, then add to a string Array() and set a flag to true.
Then, if isnumeric then, expect another name and set flag to true.
2) Read a line.
Then, loop through each character performing an isnumeric and if not then add that character to a string Array() and set flag until isnumeric again, etc....
I hope that helps or at least gets you in the right direction.
Additional variant to posted already:
Sub ZZZ()
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim num$, cl As Range, data As Range, key, x
Dim Result As Worksheet
Set data = Range([A1], Cells(Rows.Count, "A").End(xlUp))
For Each cl In data
x = "": num = "":
For Each x In Split(cl, " ")
If IsNumeric(x) Then
num = x
dic.Add x, ""
ElseIf x <> "" And num <> "" Then
dic(num) = Trim(dic(num) & " " & x)
End If
Next x
Next cl
Set Result = Worksheets.Add
With Result
.Name = "Result " & Replace(Now, ":", "-")
x = 1
For Each key In dic
.Cells(x, "A").Value2 = key
.Cells(x, "B").Value2 = dic(key)
x = x + 1
Next key
.Columns("A:B").AutoFit
End With
End Sub
test:
I have an Excel cell with text. Some words are bolded. Those words are keywords and should be extracted to another cell in the row for identification of the keywords.
Example:
Text in Cell:
I want to use Google Maps for route informations
Output:
Google; Maps; route;
You can also use this UDF to produce same result. Please enter below code in module.
Public Function findAllBold(ByVal rngText As Range) As String
Dim theCell As Range
Set theCell = rngText.Cells(1, 1)
For i = 1 To Len(theCell.Value)
If theCell.Characters(i, 1).Font.Bold = True Then
If theCell.Characters(i + 1, 1).Text = " " Then
theChar = theCell.Characters(i, 1).Text & ", "
Else
theChar = theCell.Characters(i, 1).Text
End If
Results = Results & theChar
End If
Next i
findAllBold = Results
End Function
Now you can use newly created function to return bold values from any cell.
Try this
Option Explicit
Sub Demo()
Dim ws As Worksheet
Dim str As String, strBold As String
Dim isBold As Boolean
Dim cel As Range
Dim lastRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your data sheet
isBold = False
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
For Each cel In .Range("A1:A" & lastRow).Cells 'loop through each cell in Column A
strBold = ""
For i = 1 To Len(cel.Value)
If cel.Characters(Start:=i, Length:=1).Font.Bold = True Then 'check if character is bold
isBold = True
str = Mid(cel.Value, i, 1)
If cel.Characters(Start:=i, Length:=1).Text = " " Then 'check for space
strBold = strBold & "; "
isBold = False
Else
strBold = strBold & str
End If
Else
If isBold Then
strBold = strBold & "; "
isBold = False
End If
End If
Next
cel.Offset(0, 1) = strBold
Next
End With
End Sub
Derived this code from here.
I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v