Question

您好，我正在查看如何编辑我的代码，以便不是将字符串开头的字体颜色变为红色和粗体，而是将这些字符串粘贴到另一个工作表中，但是有时候我会尝试编辑它我总是遇到运行时错误。任何帮助将不胜感激，这是我目前的代码：

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

Answer 1

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

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

Answer 2

那么根据你所说的我认为这就是你要找的东西？如果搜索字符串中的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

如果字符串包含特定值，则复制字符串的vba代码

2 个答案: