I was creating a macro to reverse the capitalization of cell values, to explain better.
Original values-
hh3crd220
xmi4Idc200
TEst02NoW
Output-
HH3CRD220
XMI4iDC200
teST02nOw
I think there must already be macros which would do the job, but i was coding one myself, everything works fine except changing the nth value, Mid is not working since it will only extract the value, i tried Character but that will only format the element, i wanted something like character.value or mid.value function to work.
Sub CapsChange()
Dim letr As String
Dim Val1 As String
Dim sr As Range
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Set sr = Range("A1:A" & lastrow)
For Each r In sr
Fval = r.Value
Val1 = Left(r.Value, 1)
If Val1 <> UCase(Val1) Then
For i = 1 To Len(Fval)
letr = Mid(Fval, i, 1)
If letr = UCase(letr) Then
**'First Code try**
letr = LCase(letr)
**'Second Code try**
r.Characters(i, 1).Value = LCase(letr)
Else
letr = UCase(letr)
r.Characters(i, 1).Value = UCase(letr)
End If
Next i
End If
Next
End Sub
Just Need Help changing/controlling the nth character of cell value, like we use cell(x,y).value = XXX.
try this:
variant 1 using SUB()
Sub Test()
Dim rng As Range, cl As Range, i&
Set rng = Range("A1:A" & Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
For Each cl In rng.Cells
For i = Len(cl.Value) To 1 Step -1
With cl.Characters(i, 1)
If .Text = UCase(.Text) Then
.Text = LCase(.Text)
ElseIf .Text = LCase(.Text) Then
.Text = UCase(.Text)
End If
End With
Next i, cl
End Sub
variant 2 using Function()
Public Function ReverseCase(cl As Range)
Dim StringOutput$, i&
For i = Len(cl.Value) To 1 Step -1
With cl.Characters(i, 1)
If .Text = UCase(.Text) Then
StringOutput = LCase(.Text) & StringOutput
ElseIf .Text = LCase(.Text) Then
StringOutput = UCase(.Text) & StringOutput
End If
End With
Next i
ReverseCase = StringOutput
End Function
test for function()
both variants are tested, works fine
You can use the Mid statement , which allows in place modification of a string:
Sub CapsChange()
Dim letr As String
Dim Val1 As String
Dim sr As Range
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Set sr = Range("A1:A" & lastrow)
For Each r In sr
Fval = r.Value
Val1 = Left(r.Value, 1)
If Val1 <> UCase(Val1) Then
For i = 1 To Len(Fval)
letr = Mid(Fval, i, 1)
If letr = UCase(letr) Then
Mid(Fval,i,1) = LCase(letr)
else
Mid(Fval,i,1) = UCase(letr)
End If
Next i
End If
Next
End Sub
Something like the below function would be far easier to re-use!
Here is how to use it :
Option Explicit
Sub test_Angad_Arora()
Dim wS As Worksheet, _
LastRow As Long, _
i As Long
Set wS = ActiveSheet
With wS
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
.Cells(i, 1) = InvertCaseCore(.Cells(i, 1))
Next i
End With
End Sub
And the function that invert the capatilization of the inputed string:
Public Function InvertCaseCore(StringToReCapitalize As String)
Dim l As Integer, _
c As String, _
OutPut As String, _
i As Integer
l = Len(StringToReCapitalize)
For i = 1 To l
c = Mid(StringToReCapitalize, i, 1)
If (c >= "A") And (c <= "Z") Then
c = LCase(c)
ElseIf (c >= "a") And (c <= "z") Then
c = UCase(c)
End If
OutPut = OutPut & c
Next i
InvertCaseCore = OutPut
End Function
You're looking for the replace-Function (See this link).
An example:
Replace("abCabCde", "C", "c", , 1)
This will find the first (and only the first) occurrence of "C" in "abCabCde" and replaces it with "c" to get "abcabCde".
Related
sub macro() is for copying values from another sheet and extract only the 2 first words from each cell then comparing all the cells and count the cells that are repeated
I'd like to simplify my code by eliminating a loop it seems like the 3rd loop can be eliminated .
the first loop is for copying values from another sheet and extract only the 2 first words from each cell using the getsummary function.
the second and the third loop is for comparing all the cells then counting the cells that are repeated
Public Function GetSummary(text As String, num_of_words As Long) As String
If (num_of_words <= 0) Then
GetSummary = ""
Exit Function
End If
Dim words() As String
words = Split(text, " ")
Dim wordCount As Long
wordCount = UBound(words) + 1
Dim result As String
Dim i As Long
i = 0
Do While (i < num_of_words And i < wordCount)
result = result & " " & words(i)
i = i + 1
Loop
GetSummary = result
End Function
sub macro()
Dim i As Long, j As Long, z As Long, cell As Range, rng As Range, rng2 As Range, A As String, k As Integer, var As String
k = 0
var = Application.InputBox(prompt:="nom du sheet")
Sheets.Add.Name = var
If var = "" Then
Exit Sub
Else
For i = 7 To 2585
Set cell = Worksheets("MRT").Range("E" & i)
A = cell.Value
Worksheets(var).Range("C" & i).Value = GetSummary(A, 2)
Worksheets(var).Range("B" & i) = cell
Next i
End If
For j = 7 To 2585
Set rng = Worksheets(var).Range("C" & j)
If rng = "" Then
rng.Offset(0, 1) = ""
Else
For z = 7 To 2585
Set rng2 = Worksheets(var).Range("C" & z)
If rng2 = rng Then
k = k + 1
End If
Next z
rng.Offset(0, 1) = k
k = 0
End If
Next j
End Sub
Try this:
Sub macro()
Dim i As Long, j As Long, var As String, start As Long, finish As Long, countRange As Range, inCache, outCache
start = 7: finish = 2585
var = Application.InputBox(prompt:="nom du sheet")
Sheets.Add.Name = var
If var = "" Then
Exit Sub
Else
inCache = Worksheets("MRT").Cells(start, 5).Resize(finish - start + 1, 1).Value2
outCache = Worksheets(var).Cells(start, 2).Resize(finish - start + 1, 2).Value2
For i = start - 6 To finish - 6
outCache(i, 1) = inCache(i, 1)
outCache(i, 2) = GetSummary(CStr(inCache(i, 1)), 2)
Next i
Worksheets(var).Cells(start, 2).Resize(finish - start + 1, 2).Value2 = outCache
End If
outCache = Worksheets(var).Cells(start, 3).Resize(finish - start + 1, 2).Value2
Set countRange = Worksheets(var).Cells(start, 3).Resize(finish - start + 1)
For j = start - 6 To finish - 6
If outCache(j, 1) = vbNullString Then
outCache(j, 2) = vbNullString
Else
outCache(j, 2) = WorksheetFunction.CountIf(countRange, outCache(j, 1))
End If
Next j
Worksheets(var).Cells(start, 3).Resize(finish - start + 1, 2).Value2 = outCache
End Sub
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
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
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