如果字符串包含某个值，则用于复制字符串的 vba 代码答案

【问题标题】：vba code for copying a string if it contains a certain value如果字符串包含某个值，则用于复制字符串的 vba 代码
【发布时间】：2017-11-14 11:53:56
【问题描述】：

您好，我正在研究如何编辑我的代码，而不是将字符串开头的字体颜色变为红色和粗体，而是将这些字符串粘贴到另一个工作表中，但是每当我尝试编辑它时，我总是最终出现运行时错误。任何帮助将不胜感激，这是我当前的代码：

Sub colorText()

    Dim cl As Range
    Dim startPos As Integer
    Dim totalLen As Integer
    Dim searchText As String
    Dim endPos As Integer
    Dim testPos As Integer

     ' specify text to search.
     searchText = "(9)"

    ' loop trough all cells in selection/range
     For Each cl In Range("A:A")
      totalLen = Len(searchText)
      startPos = InStr(cl, searchText)
      testPos = 0

      Do While startPos > testPos
         With cl.Characters(startPos, totalLen).Font
          .FontStyle = "Bold"
          .ColorIndex = 3
         End With

    endPos = startPos + totalLen
    testPos = testPos + endPos
     startPos = InStr(testPos, cl, searchText, vbTextCompare)
  Loop

Next cl

End Sub

【问题讨论】：

在 VBA 中使用过滤器应该能够快速完成，并且可能不需要循环。您的数据是否从单元格 A1 开始？测试列中没有标题吗？
我建议不要使用整个列，因为范围可能会导致一些问题。 searchText 的位置对您来说很重要，还是只想在使用 cl.value 找到 searchText 时将字符串复制到另一张纸上？
我无法用您发布的代码重现您的问题。您的代码的哪一行有错误？您的代码的哪一行是您尝试执行Copy 操作的修改？
是的，我的数据从单元格 A1 开始并且没有标题，searchText 的位置并不重要，我只想能够创建一个命令，它可以在我的工作表中搜索并复制带有我想要的位的字符串，因为有很多数据要搜索，这将为我节省很多时间。

标签： vba excel copy-paste worksheet-function

【解决方案1】：

所以根据你所说的，我认为这就是你要找的东西？如果要搜索的字符串中 SearchString 的位置与您所说的不相关，则您当前的代码实际上没有意义。

Sub CopyMatchedValuesToSheet()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRowSource As Long, i As Long
Dim SearchString As String
Dim cell As Range

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

SearchString = "2" ' Set SearchString value or use the one below if you want to change it each time

'SearchString = Application.InputBox("Give a string", "SearchString", Type:=2)

i = 1

With ws1
    LastRowSource = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
    
    For Each cell In .Range("A1:A" & LastRowSource) ' Change to A2 if it has header
        If InStr(cell.Value, SearchString) > 0 Then
            ws2.Cells(i + 1, 1).Value = cell.Value
            i = i + 1
        End If
    Next cell
End With

End Sub

您可以使用以下每次清除Sheet2，只需将代码更改为：

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2") 
ws2.Cells.Clear

【讨论】：

【解决方案2】：

如果我正确地理解了您的问题，您只需构造要复制的字符串，并将其分配给您想要的单元格：

Dim temp as String
If Not startPos = 0 Then
    temp = Mid(cl, startPos)   
    Sheets("sheet2").Cells(cl.Row, cl.Column) = temp
End If

【讨论】：