vba 复制包含特定值的字符串的代码

vba code for copying a string if it contains a certain value

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

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

如果我正确理解了你的问题,你只需要构建你想要复制的字符串,并将它分配给你想要的单元格:

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

所以根据你所说的,我假设这就是你要找的东西? 如果要搜索的字符串中 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