使用VBA复制包含特定字符的范围中的单元格
我需要能够将单元格从一列复制到另一个包含特定字符的单元格。 在这个例子中，他们将是^和*字符可以在单元格中的任何顺序。
这里是一个例子：
看起来好像我可以在VBA中使用InStr函数来做到这一点，如果我没有弄错的话。
为列表中的每个项目运行一个循环，并用类似下面的方法检查它：
IF InStr(1,Range("A" & i), "^") <> 0 AND InStr(1, Range("A" & i), "*") <> 0 THEN 'copy cell to another place End If 或者可能会有一个更优雅的解决scheme？
我看不到你的图像forms，但是一般比Instr()更容易，更快速。 你可以尝试这样的事情：
If Range("A" & i) Like "*[*^]*[*^]*" Then
这意味着你寻找一些文字 ，然后*或一个^， 更多的文字 ，然后*或*， 更多的文字
有关详细的语法，请看这里 。
没有循环的选项 – 使用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
或者用作无限字符search的function
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
编辑
再看一遍，受到汤姆关于过滤的回答的启发，它开始思考…… AdvancedFilter可以完成你想要做的事情。 它被devise在Excel的电子表格中，但是你可以在VBA中使用它。
如果你只想使用VBA，或者你的filter不会经常变化，那么这可能不是你最好的select……但是如果你想从工作簿的一面看到更加明显和灵活的东西，将是一个不错的select。
要手动运行Advanced Filter …
示例代码和dynamicfilter场景 …
（注意你可以使用方程式）
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自动为它的标准和输出创buildNamedRanges。 这可以很方便，因为你可以引用NamedRange作为Extract ，它会dynamic更新。
原始post
这里有一些代码， 我从一个类似的post中得到了一个“宽容的” 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，它是专为强大的复杂匹配而devise的。