最新消息:雨落星辰是一个专注网站SEO优化、网站SEO诊断、搜索引擎研究、网络营销推广、网站策划运营及站长类的自媒体原创博客

excel - Select multiple rows, copy and paste - Stack Overflow

programmeradmin2浏览0评论

I have data in a Google sheet and would like to select all - copy - paste into Excel.

For some of the rows, there is text within square brackets I need to be Red.

Example: ‘Insert text here [Highlighted Text]’

I am using this macro:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Text As String
    Dim Index1 As Long
    Dim Index2 As Long
    Text = Target.Text
    Index2 = 1
    Do
        Index1 = InStr(Index2, Text, "[")
        If Index1 = 0 Then Exit Do
        Index2 = InStr(Index1, Text, "]")
        If Index2 = 0 Then Exit Do
        Target.Characters(Index1, Index2 - Index1 + 1).Font.Color = &HFF
    Loop
End Sub

It works if I move data one row by one row.

However, it’s a few thousand rows so I need to select all, copy all, and paste all.
When I do this, an error message will pop up.

I have data in a Google sheet and would like to select all - copy - paste into Excel.

For some of the rows, there is text within square brackets I need to be Red.

Example: ‘Insert text here [Highlighted Text]’

I am using this macro:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Text As String
    Dim Index1 As Long
    Dim Index2 As Long
    Text = Target.Text
    Index2 = 1
    Do
        Index1 = InStr(Index2, Text, "[")
        If Index1 = 0 Then Exit Do
        Index2 = InStr(Index1, Text, "]")
        If Index2 = 0 Then Exit Do
        Target.Characters(Index1, Index2 - Index1 + 1).Font.Color = &HFF
    Loop
End Sub

It works if I move data one row by one row.

However, it’s a few thousand rows so I need to select all, copy all, and paste all.
When I do this, an error message will pop up.

Share Improve this question edited Apr 5 at 12:12 CommunityBot 11 silver badge asked Dec 21, 2024 at 4:14 russetsyrenrussetsyren 471 silver badge4 bronze badges 0
Add a comment  | 

3 Answers 3

Reset to default 2

When you paste a range, then the Target will be also a range not a single cell.
Therefore need to iterate through the range.
The below mod of your code will do that.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Text As String
Dim Index1 As Long
Dim Index2 As Long

For Each cel In Target
Text = cel.Text
Index2 = 1
    Index1 = InStr(Index2, Text, "[")
    If Index1 <> 0 Then
        Index2 = InStr(Index1, Text, "]")
        If Index2 <> 0 Then
            cel.Characters(Index1, Index2 - Index1 + 1).Font.Color = &HFF
        End If
    End If
Next cel
    End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim regex As Object, m As Object, cel as Range, r As Long
    Dim t0 As Single: t0 = Timer
    
     ' build regex pattern
    Set regex = CreateObject("vbscript.regexp")
    With regex
       .Global = True
       .MultiLine = True
       .IgnoreCase = True
       .Pattern = "\[([^]]+)\]" ' [(any text not ])]
    End With
    
    ' color text inside []
    For Each cel In Target.Cells
       For Each m In regex.Execute(cel)
           cel.Characters(m.firstindex + 2, Len(m) - 2).Font.Color = vbRed '&HFF
           'r = r + 1
       Next
    Next
    'MsgBox Target.Cells.Count & " cells scanned" & vbLf & r & " changes in " & _
    '       Format(Timer - t0, "0.0 secs"), vbInformation, Target.Address

End Sub

An alternative using Regular Expressions which works only in Column A

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myStr As String, regExp As Object, j As Integer
    Dim objMatches As Object, xRng As Range, xMatch As Object
    
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        Set regExp = CreateObject("VBscript.RegExp")
        
        regExp.Pattern = "\[(.*?)\]"
        regExp.Global = True
        
        For Each xRng In Selection
            j = 0
            Set objMatches = regExp.Execute(xRng.Text)
            For Each xMatch In objMatches
                xRng.Characters(xMatch.FirstIndex + j, xMatch.Length + 1).Font.Color = vbRed
            Next
        Next
    End If
    
    Set objMatches = Nothing
    Set regExp = Nothing
End Sub
发布评论

评论列表(0)

  1. 暂无评论