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