Question

我需要能够将单元格从一列复制到另一列包含特定字符。在这个例子中，它们将是^和*字符可以在单元格中的任何顺序。

以下是一个例子：

看起来我可以在VBA中使用InStr函数来实现这一点，如果我没有弄错的话。

为列表中的每个项目运行一个循环，并使用以下内容进行检查：

IF InStr(1,Range("A" & i), "^") <> 0 AND InStr(1, Range("A" & i), "*") <> 0 THEN

'copy cell to another place

End If

或者可能有更优雅的解决方案？

Answer 1

我无法看到您的图片形式，但settings.py通常比.py更容易，更快捷。你可以尝试这样的事情：

Like

意味着您要查找某些文字，然后*或者^，更多文字，然后是*或*，更多文字

有关详细语法，请查看here。

Answer 2

无循环选项 - 使用Arrays和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

或者用作无限字符搜索的功能

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

修改

再次看到这一点并受到Tom关于过滤的回答的启发，我们开始思考...... AdvancedFilter可以完全按照您的意愿去做。它设计在Excel的电子表格端，但您可以在VBA中使用它。

如果您只想在VBA之外工作，或者您的过滤器不能经常更换，那么这可能不是您的最佳选择......但如果您想要的东西更明显，从工作簿方面来看，这是一个很好的选择。

手动运行Advanced Filter ...

示例代码和动态过滤器方案 ...

（注意你可以使用方程式）

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

命名范围

AdvancedFitler会自动为其标准和输出创建NamedRanges。这可能很方便，因为您可以将NamedRange引用为Extract，它将动态更新。

原帖

以下是＆＃34;宽容＆＃34;的一些代码。来自a similar post I made的InStr()函数...它并不是完全根据您的示例进行定制的，但它是基于逐个字符分析的基本点。

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

另外，在这些情况下，我总是觉得有必要提到Regex。虽然它不是最容易使用的，特别是对于VBA，它的设计完全适用于强大的复杂匹配。

使用VBA复制包含特定字符

3 个答案: