Excel VBA-正则表达式汇总

 

========================

   'Pattern代码汇总
    '^\s 替换行首空格
    '^\n 替换行首的换行符
    '"^\d\.\s*" 去除序号
    '^(.*)$ 匹配整行

========================

Private Sub 批量替换去除无用字符()
    Application.ScreenUpdating = False '关闭屏幕刷新

    Dim RegExp As Object
    Dim SearchRange As Range, Cell As Range
     
    '此处定义正则表达式
    Set RegExp = CreateObject("vbscript.regexp")

    '初始化正则对象
    With RegExp
    .Global = True
    .IgnoreCase = True
    .MultiLine = True
    .Pattern = "^\n"
    End With

    '此处指定查找范围
    Set SearchRange = Selection
     
    '遍历查找范围内的单元格
    For Each Cell In SearchRange
        Set matches = RegExp.Execute(Cell.Value)
        If matches.Count >= 1 Then
            Cell.Value = RegExp.Replace(Cell.Value, "")
        End If
    Next

Application.ScreenUpdating = True '开启屏幕刷新
End Sub

========================

Private Sub 单元格内每行内容添加序号()
    Application.ScreenUpdating = False '关闭屏幕刷新

    Dim RegExp As Object
    Dim SearchRange As Range, Cell As Range
     
    '此处定义正则表达式
    Set RegExp = CreateObject("vbscript.regexp")

    '初始化正则对象
    With RegExp
    .Global = True
    .IgnoreCase = True
    .MultiLine = True
    .Pattern = "^(.*)$"
    End With

    '此处指定查找范围
    Set SearchRange = Selection
     
    '遍历查找范围内的单元格
    For Each Cell In SearchRange
        Set matches = RegExp.Execute(Cell.Value)
         If matches.Count > 1 Then
            For Each Match In matches
                n = n + 1
                strcell = strcell & n & ".  " & Match.Value & Chr(10)
            Next
	'最后一行多了一个Chr(10),需要截去
            Cell.Value = Mid(strcell, 1, Len(strcell) - 1)
        End If
    Next

    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

========================

Public Sub 用空格连接选中单元格内容()
    Dim str As String, temp As String, CXrng As Range, XRrng As Range
    Set CXrng = Selection
 
    For Each XRrng In CXrng
        str = str & Chr(32) & XRrng.Value
        XRrng.ClearContents
    Next
    CXrng(1) = str
End Sub

'连接多个单元格文本，使用Alt+Enter
Public Sub 用Alt+Enter连接选中单元格内容()
    Dim str As String, temp As String, CXrng As Range, XRrng As Range
    Set CXrng = Selection
 
    For Each XRrng In CXrng
        str = str & Chr(10) & XRrng.Value
         XRrng.ClearContents
    Next
     CXrng(1) = str
End Sub

======================

Sub 正则表达式提取匹配文本()
	'定义正则对象和单元格区域
	Dim rngRg As Range
	Dim objRe As Object
	
	'创建正则对象，并将当前选择区域赋值给rngRg
	Set objRe = CreateObject("vbscript.regexp")
	Set rngRg = Selection
	
	'初始化正则对象
	With objRe
	.Global = True
	.IgnoreCase = True
	.MultiLine = True
	.Pattern = "AAA"
	End With
	
	'遍历选择区域的每个单元格
	For Each cell In rngRg
	'如果有符合正则表达式的对象
	    If objRe.test(cell.Value) Then
	'将匹配集合的所有对象的值复制给Matches对象
	        Set Matches = objRe.Execute(cell.Value)
	'遍历Mathces对象，将结果输出到右侧单元格内
	        For countM = 1 To Matches.Count
	            cell.Offset(0, countM) = Matches(countM - 1)
	        Next
	    End If
	Next
End Sub

========================

Sub 正则表达式替换内容输出到右侧列()
	Application.ScreenUpdating = False '关闭屏幕刷新
	'定义正则对象和单元格区域
	Dim rngRg As Range
	Dim objRe As Object
	
	'创建正则对象，并将当前选择区域赋值给rngRg
	Set objRe = CreateObject("vbscript.regexp")
	Set rngRg = Selection
	
	'初始化正则对象
	With objRe
	.Global = True
	.IgnoreCase = True
	.MultiLine = True
	.Pattern = "AAA"
	End With
	
	'遍历选择区域的每个单元格
	For Each cell In rngRg
	'如果有符合正则表达式的对象
	    If objRe.test(cell.Value) Then
	'将匹配集合的所有对象的值进行替换，并输出在右侧一列
	        cell.Offset(0, 1) = objRe.Replace(cell.Value, "BBB")
	    End If
	Next
	
	Application.ScreenUpdating = True'开启屏幕刷新  
End Sub

=======================

=======================

=======================

=======================

=======================

=======================

=======================

=======================

=======================

=======================

=======================

=======================