Find all possible pairs of string - VBA - vba

In the column A, I have a list of strings. In the next column, I'd like to have all possible pairs (concatenated), such as:
|Column A | Column B|
|A| |AB|
|B| |AC|
|C| |BC|
|...| |...|
I have over 150 strings in my column A. I guess that I'll need a double loop, but I'm not sure how to proceed.

Here's one approach.
Option Explicit
' Modify if you want to delimit the concatenated values
Const delimiter As String = vbNullString
' If you want to concatenate a cell with itself, set this to True
Const compareSelf As Boolean = False
Sub pairs_mem()
'The pairs procedure calls on ConcatValues to write out data to sheet
' this procedures create pairwise combinations of each cell
' this does not omit duplicates (items nor pairs) or any other special considerations
Dim rng As Range
Dim cl1 As Range, cl2 As Range, dest As Range
Dim i As Long, length As Long
'Range of values to be concatenated, Modify as needed
Set rng = Range("A1:A7")
length = rng.Cells.Count
'Begin putting output in B1, Modify as needed
Set dest = Range("B1")
'Get the size of the output array
' output() is array container for the output values
If compareSelf Then
ReDim output(1 To length * (length - 1))
Else
ReDim output(1 To length ^ 2)
End If
i = 1
For Each cl1 In rng.Cells
For Each cl2 In rng.Cells
If cl1.Address = cl2.Address Then
If compareSelf Then
output(i) = ConcatValues(cl1, cl2)
i = i + 1
End If
Else
output(i) = ConcatValues(cl1, cl2)
i = i + 1
End If
Next
Next
dest.Resize(UBound(output)).Value = Application.Transpose(output)
End Sub
Function ConcatValues(ParamArray vals() As Variant)
'Call this function to do the concatenation and returns the "i" value to caller
Dim s$
Dim itm
For Each itm In vals
s = s & itm & delimiter
Next
If delimiter <> vbNullString Then
s = Left(s, Len(s) - 1)
End If
ConcatValues = s
End Function

Related

How do I pass an argument from a subroutine to a function in VBA?

I'm trying to look for values to create a final ticket number for a ticket reconciliation process. This is what should happen:
subroutine looks for a value in cell "Gx"
if it finds a value
pass value to function to strip out letters, convert to a number, pass back to subroutine to place in
cell "Ax"
if there is no value
pass value of "Cx" to function etc.
This loops through the number cells I have in my worksheet based on the number of rows filled in a separate column.
The function works fine by itself in the worksheet, but when I pass it a value from the subroutine column A fills up with the number of the row ie. A37=37, A8=8. I don't think I'm passing the argument correctly to the function, but I'm not certain. Here's the code for the subroutine and the function:
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
'header label
Range("A1").Value = "Final Ticket #"
'set number of rows for loop
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
'check col G for empty, use col C as backup
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
'strip out letters in col G, place in col A
Cells(i, "A").Value = getNumeric("G" & i)
Else
'strip out letters in col C, place in col A
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
stringLength = Len(cellRef)
'loops through each character in a cell to evaluate if number or not
For i = 1 To stringLength
If IsNumeric(Mid(cellRef, i, 1)) Then
Result = Result & Mid(cellRef, i, 1)
End If
Next i
'convert remaining characters to number
getNumeric = CLng(Result)
End Function
What am I missing?
As I understand it, the only thing that is wrong is your Len (cellRef), here you are only passing the range and not his value. See how I did it, I had to specify the spreadsheet, do the same that will work.
Use debug.print to see the outputs of the variables. Write in the code "debug.print XvariableX" and in the immediate check (Ctrl + G) you see the value assigned to the variable. good luck.
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
Range("A1").Value = "Final Ticket #"
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
Cells(i, "A").Value = getNumeric("G" & i)
Else
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
Dim Wrs As String
Wrk = ActiveWorkbook.Name
Workbooks(Wrk).Activate
Wrs = ActiveSheet.Name
stringLength = Len(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef))
For i = 1 To stringLength
If IsNumeric(Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)) Then
Result = Result & Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)
End If
Next i
getNumeric = CLng(Result)
End Function

Format cells with the same values split by a delimiter, but a different order in VBA

I am a VBA beginner, who cannot seem to find a solution to what seemed to be a very easy comparison to me at first.
Basically, I have 2 columns where the values in the cells are split by a delimiter, however, not in the same order.
eg.
Range("A1").value = "1234|5678"
Range("B1").value = "5678|1234"
B1 should then be highlighted as a duplicate
I am searching for some vba code which I can use to loop through the used range's in Columns A & B, to compare and highlight cells in column B that are duplicated, as per example above.
Apologies if I missed any similar questions asked and answered previously, I have indeed conducted a search but perhaps my search criteria may have been out of bounds, and I simply did not come across the VBA solution.
Regards,
Enjay
Based on the little information given you could try the following code
Sub Highlight()
Const DELIMITER = "|"
Dim rg As Range
Dim a As Variant
Dim b As Variant
Dim sngCell As Range
Set rg = Range("A1:A3")
For Each sngCell In rg
a = Split(sngCell.Value2, DELIMITER)
b = Split(sngCell.Offset(, 1).Value2, DELIMITER)
If isEqual(a, b) Then
With sngCell.Offset(, 1).Interior
.ThemeColor = xlThemeColorAccent6
End With
End If
Next sngCell
End Sub
with the following functions
Function isEqual(a As Variant, b As Variant) As Boolean
a = BubbleSort(a)
b = BubbleSort(b)
isEqual = True
Dim i As Long
For i = LBound(a) To UBound(a)
If a(i) <> b(i) Then
isEqual = False
Exit For
End If
Next i
End Function
Function BubbleSort(ByRef strArray As Variant) As Variant
'sortieren von String Array
'eindimensionale Array
'Bubble-Sortier-Verfahren
Dim z As Long
Dim i As Long
Dim strWert As Variant
For z = UBound(strArray) - 1 To LBound(strArray) Step -1
For i = LBound(strArray) To z
If LCase(strArray(i)) > LCase(strArray(i + 1)) Then
strWert = strArray(i)
strArray(i) = strArray(i + 1)
strArray(i + 1) = strWert
End If
Next i
Next z
BubbleSort = strArray
End Function
This will answer your question as-is. If the solution needs to be adjusted, I trust that you can fix it :)
This uses StrComp to (in memory only) re-order the two string parts so that it can easily detect duplicate values.
Option Explicit
Sub DuplicateCheck()
Dim delimiter As String
delimiter = "|"
Dim lastCol As Long
lastCol = Cells(1, Columns.count).End(xlToLeft).Column
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To lastCol
Dim theSplit As Variant
theSplit = Split(Cells(1, i), delimiter)
Dim temp As String
If StrComp(theSplit(0), theSplit(1), vbTextCompare) = 1 Then
temp = theSplit(1)
theSplit(1) = theSplit(0)
theSplit(0) = temp
End If
temp = theSplit(0) & delimiter & theSplit(1)
If Not dict.exists(temp) Then
dict.Add (temp), 1
Else
Cells(1, i).Interior.color = 65535
End If
Next i
End Sub

VBA for Excel code to find and change formatting of substrings of text within a cell

I'm using VBA for Excel.
I have code that does the following:
Take an array of words (called Search_Terms)
I then have a function (see below) that receives the Search_Terms and a reference to a Cell in Excel.
The function then searches the text within the cell.
It finds all substrings that match the words in Search_Terms within the cell and changes their formatting.
The function shown below already works.
However, it is quite slow when I want to search several thousand cells with an array of 20 or 30 words.
I'm wondering if there is a more efficient/idiomatic way to do this (I'm not really familiar w/ VBA and I'm just hacking my way through).
Thank you!
Dim Search_Terms As Variant
Dim starting_numbers() As Integer ' this is an "array?" that holds the starting position of each matching substring
Dim length_numbers() As Integer 'This is an "array" that holds the length of each matching substring
Search_Terms = Array("word1", "word2", "word3")
Call change_all_matches(Search_Terms, c) ' "c" is a reference to a Cell in a Worksheet
Function change_all_matches(terms As Variant, ByRef c As Variant)
ReDim starting_numbers(1 To 1) As Integer ' reset the array
ReDim length_numbers(1 To 1) As Integer ' reset the array
response = c.Value
' This For-Loop Searches through the Text in the Cell and finds the starting position & length of each matching substring
For Each term In terms ' Iterate through each term
Start = 1
Do
pos = InStr(Start, response, term, vbTextCompare) 'See if we have a match
If pos > 0 Then
Start = pos + 1 ' keep looking for more substrings
starting_numbers(UBound(starting_numbers)) = pos
ReDim Preserve starting_numbers(1 To UBound(starting_numbers) + 1) As Integer ' Add each matching "starting position" to our array called "starting_numbers"
length_numbers(UBound(length_numbers)) = Len(term)
ReDim Preserve length_numbers(1 To UBound(length_numbers) + 1) As Integer
End If
Loop While pos > 0 ' Keep searching until we find no substring matches
Next
c.Select 'Select the cell
' This For-Loop iterates through the starting position of each substring and modifies the formatting of all matches
For i = 1 To UBound(starting_numbers)
If starting_numbers(i) > 0 Then
With ActiveCell.Characters(Start:=starting_numbers(i), Length:=length_numbers(i)).Font
.FontStyle = "Bold"
.Color = -4165632
.Size = 13
End With
End If
Next i
Erase starting_numbers
Erase length_numbers
End Function
The code bellow might be a bit faster (I haven't measured it)
What it does:
Turns off Excel features, as suggested by #Ron (ScreenUpdating, EnableEvents, Calculation)
Sets the used range and captures the last used column
Iterates through each column and applies an AutoFilter for each of the words
If there is more than one visible row (the first one being the header)
Iterates through all visible cells in currently auto-filtered column
Checks that the cell doesn't contain error & is not empty (this order, distinct checks)
When it finds the current filter word makes the changes
Moves to the next cell, then next filter word until all search words are done
Moves to the next column, repeats above process
Clears all filters, and turns Excel features back on
Option Explicit
Const ALL_WORDS = "word1,word2,word3"
Public Sub ShowMatches()
Dim ws As Worksheet, ur As Range, lc As Long, wrdArr As Variant, t As Double
t = Timer
Set ws = Sheet1
Set ur = ws.UsedRange
lc = ur.Columns.Count
wrdArr = Split(ALL_WORDS, ",")
enableXL False
Dim c As Long, w As Long, cVal As String, sz As Long, wb As String
Dim pos As Long, vr As Range, cel As Range, wrd As String
For c = 1 To lc
For w = 0 To UBound(wrdArr)
If ws.AutoFilterMode Then ur.AutoFilter 'clear filters
wrd = "*" & wrdArr(w) & "*"
ur.AutoFilter Field:=c, Criteria1:=wrd, Operator:=xlFilterValues
If ur.Columns(c).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
For Each cel In ur.Columns(c).SpecialCells(xlCellTypeVisible)
If Not IsError(cel.Value2) Then
If Len(cel.Value2) > 0 Then
cVal = cel.Value2: pos = 1
Do While pos > 0
pos = InStr(pos, cVal, wrdArr(w), vbTextCompare)
wb = Mid(cVal, pos + Len(wrdArr(w)), 1)
If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
sz = Len(wrdArr(w))
With cel.Characters(Start:=pos, Length:=sz).Font
.Bold = True
.Color = -4165632
.Size = 11
End With
pos = pos + sz - 1
Else
pos = 0
End If
Loop
End If
End If
Next
End If
ur.AutoFilter 'clear filters
Next
Next
enableXL True
Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub
Private Sub enableXL(Optional ByVal opt As Boolean = True)
Application.ScreenUpdating = opt
Application.EnableEvents = opt
Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End Sub
Your code uses ReDim Preserve in the first loop (twice)
slight impact on performance for one cell, but for thousands it becomes significant
ReDim Preserve makes a copy of the initial arr with the new dimension, then deletes the first arr
Also, Selecting and Activating cells should be avoided - most of the times are not needed and slow down execution
Edit
I measured the performance between the 2 versions
Total cells: 3,060; each cell with 15 words, total search terms: 30
Initial code: Time: 69.797 sec
My Code: Time: 3.969 sec
Initial code optimized: Time: 3.438 sec
Initial code optimized:
Option Explicit
Const ALL_WORDS = "word1,word2,word3"
Public Sub TestMatches()
Dim searchTerms As Variant, cel As Range, t As Double
t = Timer
enableXL False
searchTerms = Split(ALL_WORDS, ",")
For Each cel In Sheet1.UsedRange
ChangeAllMatches searchTerms, cel
Next
enableXL True
Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub
Public Sub ChangeAllMatches(ByRef terms As Variant, ByRef cel As Range)
Dim termStart() As Long 'this array holds starting positions of each match
Dim termLen() As Long 'this array holds lengths of each matching substring
Dim response As Variant, term As Variant, strt As Variant, pos As Long, i As Long
If IsError(cel.Value2) Then Exit Sub 'Do not process error
If Len(cel.Value2) = 0 Then Exit Sub 'Do not process empty cells
response = cel.Value2
If Len(response) > 0 Then
ReDim termStart(1 To Len(response)) As Long 'create arrays large enough
ReDim termLen(1 To Len(response)) As Long 'to accommodate any matches
i = 1: Dim wb As String
'The loop finds the starting position & length of each matched term
For Each term In terms 'Iterate through each term
strt = 1
Do
pos = InStr(strt, response, term, vbTextCompare) 'Check for match
wb = Mid(response, pos + Len(term), 1)
If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
strt = pos + 1 'Keep looking for more substrings
termStart(i) = pos 'Add match starting pos to array
termLen(i) = Len(term) 'Add match len to array termLen()
i = i + 1
Else
pos = 0
End If
Loop While pos > 0 'Keep searching until we find no more matches
Next
ReDim Preserve termStart(1 To i - 1) 'clean up array
ReDim Preserve termLen(1 To i - 1) 'remove extra items at the end
For i = 1 To UBound(termStart) 'Modify matches based on termStart()
If termStart(i) > 0 Then
With cel.Characters(Start:=termStart(i), Length:=termLen(i)).Font
.Bold = True
.Color = -4165632
.Size = 11
End With
End If
Next i
End If
End Sub

Need help improving my VBA loop

I have an Excel Worksheet consisting of two columns, one of which is filled with strings and the other is emtpy. I would like to use VBA to assign the value of the cells in the empty column based on the value of the adjacent string in the other column.
I have the following code:
Dim regexAdmin As Object
Set regexAdmin = CreateObject("VBScript.RegExp")
regexAdmin.IgnoreCase = True
regexAdmin.Pattern = "Admin"
Dim i As Integer
For i = 1 To 10 'let's say there is 10 rows
Dim j As Integer
For j = 1 To 2
If regexAdmin.test(Cells(i, j).Value) Then
Cells(i, j + 1).Value = "Exploitation"
End If
Next j
Next i
The problem is that when using this loop for a big amount of data, it takes way too long to work and, most of the time, it simply crashes Excel.
Anyone knows a better way to this?
You have an unnecessary loop, where you test the just completed column (j) too. Dropping that should improve the speed by 10-50%
Dim regexAdmin As Object
Set regexAdmin = CreateObject("VBScript.RegExp")
regexAdmin.IgnoreCase = True
regexAdmin.Pattern = "Admin"
Dim i As Integer
For i = 1 To 10 'let's say there is 10 rows
If regexAdmin.test(Cells(i, 1).Value) Then
Cells(i, 1).offset(0,1).Value = "Exploitation"
End If
Next i
If the regex pattern really is simply "Admin", then you could also just use a worksheet formula for this, instead of writing a macro. The formula, which you'd place next to the text column (assuming your string/num col is A) would be:
=IF(NOT(ISERR(FIND("Admin",A1))),"Exploitation","")
In general, if it can be done with a formula, then you'd be better off doing it so. it's easier to maintain.
Try this:
Public Sub ProcessUsers()
Dim regexAdmin As Object
Set regexAdmin = CreateObject("VBScript.RegExp")
regexAdmin.IgnoreCase = True
regexAdmin.Pattern = "Admin"
Dim r As Range, N As Integer, i As Integer
Set r = Range("A1") '1st row is headers
N = CountRows(r) - 1 'Count data rows
Dim inputs() As Variant, outputs() As Variant
inputs = r.Offset(1, 0).Resize(N, 1) ' Get all rows and 1 columns
ReDim outputs(1 To N, 1 To 1)
For i = 1 To N
If regexAdmin.test(inputs(i, 1)) Then
outputs(i, 1) = "Exploitation"
End If
Next i
'Output values
r.Offset(1, 1).Resize(N, 1).Value = outputs
End Sub
Public Function CountRows(ByRef r As Range) As Long
If IsEmpty(r) Then
CountRows = 0
ElseIf IsEmpty(r.Offset(1, 0)) Then
CountRows = 1
Else
CountRows = r.Worksheet.Range(r, r.End(xlDown)).Rows.Count
End If
End Function

Feed variable from array

How can I feed variable "CatchPhrase" with value from each cell from col S...?
I need to select all rows that contain value from each cell in col S.
Problem is that col S have 1996 diferent numbers, and col A have 628790 numbers..
Sub SelectManyRows()
Dim CatchPhrase As String
Dim WholeRange As String
Dim AnyCell As Object
Dim RowsToSelect As String
CatchPhrase = "10044"
'first undo any current highlighting
Selection.SpecialCells(xlCellTypeLastCell).Select
WholeRange = "A1:" & ActiveCell.Address
Range(WholeRange).Select
On Error Resume Next ' ignore errors
For Each AnyCell In Selection
If InStr(UCase$(AnyCell.Text), UCase$(CatchPhrase)) Then
If RowsToSelect <> "" Then
RowsToSelect = RowsToSelect & "," ' add group separator
End If
RowsToSelect = RowsToSelect & Trim$(Str$(AnyCell.Row)) & ":" & Trim$(Str$(AnyCell.Row))
End If
Next
On Error GoTo 0 ' clear error 'trap'
Range(RowsToSelect).Select
End Sub
Example of what I need:
Using the same approach as Is it possible to fill an array with row numbers which match a certain criteria without looping?
You can return an array of numbers from column A (I have used A1:A200 in this example) that match a list in S1:S9 as below
Sub GetEm()
Dim x
x = Filter(Application.Transpose(Application.Evaluate("=if(NOT(ISERROR(MATCH(A1:A200,$S$1:S9,0))),a1:a200,""x"")")), "x", False)
End Sub
The second sub does a direct selection of these cells
Sub GetEm2()
Dim x1
x1 = Join(Filter(Application.Transpose(Application.Evaluate("=if(NOT(ISERROR(MATCH(A1:A200,$S$1:S9,0))),""a""&row(a1:a200),""x"")")), "x", False), ",")
Application.Goto Range(x1)
End Sub
Consider:
Sub dural()
Dim rS As Range, wf As WorksheetFunction
Dim N As Long, aryS As Variant, rSelect As Range
Dim i As Long, v As Variant
'
' Make an array from column S
'
N = Cells(Rows.Count, "S").End(xlUp).Row
Set wf = Application.WorksheetFunction
Set rS = Range("S1:S" & N)
aryS = wf.Transpose(rS)
'
' Loop down column A looking for matches
'
Set rSelect = Nothing
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
If v = Filter(aryS, v)(0) Then
If rSelect Is Nothing Then
Set rSelect = Cells(i, 1)
Else
Set rSelect = Union(Cells(i, 1), rSelect)
End If
End If
Next i
'
' Select matching parts of column A
'
rSelect.Select
End Sub