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

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?

Try or in the IF statement `IF InStr(1, LCase(Range("A" & i)), "^") <> 0 OR InStr(1, LCase(Range("A" & i)), "*") <> 0 THEN` — nishit dey, Oct 12 '17 at 12:42
I need it locate both ^ and * no matter where they are in the cell that's why I had used the AND operator my question didn't specify that correctly it has been updated — Matt, Oct 12 '17 at 12:42
why do you need the LCase as you are looking for either ^ or * ? — QHarr, Oct 12 '17 at 12:45
FYI, I added info to my answer about using `AdvancedFilter`. Not as good on the VBA side, but better on the Worksheet side. — u8it, Oct 12 '17 at 16:19

score 4 · Accepted Answer · answered Oct 12 '17 at 12:56

4

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.

answered Oct 12 '17 at 12:56

iDevlop

24,841
11
90
149

Very simple and fast I like this solution – Matt Oct 12 '17 at 13:15

Tom · Answer 2 · 2017-10-12T13:13:14.537

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

I like this answer. The ultimate generalization of what the OP describes is an order independent intersect of a dynamic listA with dynamic ListB as inputs... the `Like` operator doesn't really do this. — u8it, Oct 12 '17 at 13:35

u8it · Answer 3 · 2017-10-12T16:17:06.393

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.

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

3 Answers3