Use VBA to copy cells in a Range that contain specific characters - vba

Question

I need to be able to copy cells from one column to another that contain specific characters. In this example they would be ^ and * the characters can be in any order in the cell.
Here is an example :
It looks like I might be able to use the InStr function in VBA to accomplish this if I am not mistaken.
Run a loop for each item in the list and check it with something like the following:
IF InStr(1,Range("A" & i), "^") <> 0 AND InStr(1, Range("A" & i), "*") <> 0 THEN
'copy cell to another place
End If
or might there be a more elegant solution?

Answer 1

I can't see your image form where I am, but Like is generally easier and faster than Instr(). You could try something like this:
If Range("A" & i) Like "*[*^]*[*^]*" Then
meaning you look for some text, then * or a ^, more text, then * or *, more text
For detailed syntax, look here.

Answer 2

Option for no loops - use Arrays and Filter
Option Explicit
Sub MatchCharacters()
Dim src As Variant, tmp As Variant
Dim Character As String, Character2 As String
Character = "*"
Character2 = "^"
' Replace with your sheetname
With Sheet1
src = Application.Transpose(Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
tmp = Filter(Filter(src, Character), Character2)
.Range(.Cells(2, 3), .Cells(.Cells(1, 3).End(xlDown).Row, 3)).ClearContents
If UBound(tmp) > -1 Then
With .Cells(2, 3)
Range(.Offset(0, 0), .Offset(UBound(tmp), 0)).Value2 = Application.Transpose(tmp)
End With
End If
End With
End Sub
Or use as a function with unlimited character searching
Public Function MatchCharacters(arr As Variant, ParamArray Characters() As Variant) As Variant
Dim i As Long
For i = LBound(Characters) To UBound(Characters)
arr = Filter(arr, Characters(i))
Next i
MatchCharacters = arr
End Function
Sub test()
Dim tmp As Variant
With Sheet1
tmp = Application.Transpose(Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
tmp = MatchCharacters(tmp, "*", "^")
If UBound(tmp) > -1 Then
With .Cells(2, 3)
Range(.Offset(0, 0), .Offset(UBound(tmp), 0)).Value2 = Application.Transpose(tmp)
End With
End If
End With
End Sub

Answer 3

Edit
Looking at this again and being inspired by Tom's answer about filtering, it got be thinking... the AdvancedFilter can do exactly what you're looking to do. It's designed into the spreadsheet side of Excel, but you can use it from VBA.
If you only want to work out of VBA, or if your filter won't be changing often, then this probably is not your best choice... but if you want something that's more visible and flexible from the workbook side of things, this would be a good choice.
To manually run Advanced Filter...
Example code and dynamic filter scenario...
(Notice you can use equations with it)
Sub RunCopyFilter()
Dim CriteriaCorner As Integer
CriteriaCorner = Application.WorksheetFunction.Max( _
Range("B11").End(xlUp).Row, _
Range("C11").End(xlUp).Row, _
Range("D11").End(xlUp).Row)
[A4:A10].AdvancedFilter xlFilterCopy, Range("B4:D" & CriteriaCorner), [E4:E10], True
End Sub
Named Ranges
AdvancedFitler automatically creates NamedRanges for it's criteria and output. That can be handy because you can reference the NamedRange as Extract and it will dynamically update.
Original Post
Here's some code for a "tolerant" InStr() function from a similar post I made... it isn't tailored exactly to your example, but it gets at the basic point of character-by-character analysis.
Function InStrTolerant(InputString As String, MatchString As String, Optional CaseInsensitiveChoice = False, Optional Tolerance As Integer = 0) As Integer
'Similar to InStr, but allows for a tolerance in matching
Dim ApxStr As String 'Approximate String to Construct
Dim j As Integer 'Match string index
j = 1
Dim Strikes As Integer
Dim FoundIdx As Integer
For i = 1 To Len(InputString)
'We can exit early if a match has been found
If StringsMatch(ApxStr, MatchString, CaseInsensitiveChoice) Then
InStrTolerant = FoundIdx
Exit Function
End If
If StringsMatch(Mid(InputString, i, 1), Mid(MatchString, j, 1), CaseInsensitiveChoice) Then
'This character matches, continue constructing
ApxStr = ApxStr + Mid(InputString, i, 1)
j = j + 1
FoundIdx = i
Else
'This character doesn't match
'Substitute with matching value and continue constructing
ApxStr = ApxStr + Mid(MatchString, j, 1)
j = j + 1
'Since it didn't match, take a strike
Strikes = Strikes + 1
End If
If Strikes > Tolerance Then
'Strikes exceed tolerance, reset contruction
ApxStr = ""
j = 1
Strikes = 0
i = i - Tolerance
End If
Next
If StringsMatch(ApxStr, MatchString, CaseInsensitiveChoice) Then
InStrTolerant = FoundIdx
Else
InStrTolerant = 0
End If
End Function
Also, I always feel obliged to mention Regex in these cases. Although it isn't the easiest to use, especially with VBA, it is designed exactly for powerful complex matching.