ctrl+e 3行时间有点出入 不过大多数都ok
Power Query解法
不是针对你附件里的黄色部分的么?=TRIM(MID(SUBSTITUTE(REPLACE(REPLACE(REPLACE($A3,5,0,""),FIND("20",$A3)+2,0,""),LEN(REPLACE(REPLACE($A3,5,0,""),FIND("20",$A3)+3,0,"")),0,""),"",REPT("",99)),COLUMN(a1)*200-199,200))
试一下下面代码，运行“提取内容”代码即可：
Public Function GFNC(ByVal s As String) As Integer
'定义在字符串中找到第一个数字字符位置的函数GFNC(GetPositionOfFirstNumericCharacter)，网上有
For i = 1 To Len(s)
Dim currentCharacter As String
currentCharacter = Mid(s, i, 1)
If IsNumeric(currentCharacter) = True Then
GFNC = i
Exit Function
End If
Next i
End Function
Sub 提取内容()
Dim i As Integer
For i = 1 To 5
Range("c" & i) = Left(Range("a" & i), GFNC(Range("a" & i)) - 1)
Range("d" & i) = Right(Split(Range("a" & i), "202")(0), VBA.Len(Split(Range("a" & i), "202")(0)) - GFNC(Range("a" & i)) + 1)
Range("f" & i) = Right(Range("a" & i), 1)
Range("e" & i) = Split(Replace(Left(Range("a" & i), VBA.Len(Range("a" & i)) - 1), "202", "*202"), "*")(1)
Next
End Sub
说明、解释：
数据虽少，但比较复杂。
目标是取＂企业名称＂、＂内容＂、“日期＂、＂责任人＂。
找目标规律：
＂企业名称＂在字符串最左，后面是数字
＂内容＂是第1个数字与202之间字符串
“日期＂日期开头都有202字符串并为右第二位起
＂责任人＂都是最后1位
找到规律，逐行给B、C、D、E单元格赋值了。
完成任务，仅用函数解决不了，要写代码。
还要定义在字符串中找到第一个数字字符位置的函数GFNC(GetPositionOfFirstNumericCharacter)。
如果数据增加，修改“For i = 1 To 5”中的5即，有多少行，填写多少。
几个代码的含义：
Range("a11") = Character(Range("a1")) '第一个数字位数
Range("a8") = VBA.Len(Range("a1")) '第一行总数
Range("a10") = Left(Range("a1"), VBA.Len(Range("a1")) - 1) '取除最后一位
Range("a12") = VBA.Len(Range("a1"), "202", "*202")
Range("b14") = Replace(Range("a1"), "202", "*202") '用*将202后面数字隔开，直接取后面数字
Range("a16") = Split(Range("a1"), "202")(0) '取202前各位
'从2020或2021数字前取字符串，取“2020或2021数字前符串”减去第位数字加上1的字符串
Range("a18") = Right(Split(Range("a1"), "202")(0), VBA.Len(Split(Range("a1"), "202")(0)) - GFNC(Range("a1")) + 1)
sorry,“Range("a11") = Character(Range("a1")) '第一个数字密码”为：
Range("a11") = GFNC(Range("a1")) '第一个数字字符位置数
学习了一下正则表达式，根据需要提取的字符特点，定义4个函数，然后分别提取，比较清晰。前一个太复杂了，容易看乱：
Function shz(str As String)
'自定义提取首段汉字字符函数
With CreateObject("vbscript.RegExp")
.Global = ture
.IgnoreCase = False
.MultiLine = True
.Pattern = "^[\u4e00-\u9fa5]+" '以汉字开关的所有字符
If .test(str) Then
shz = .Execute(str)(0) '要匹配的目标(0)为匹配一次
Else
shz = "" '没有就返回空，防止出错
End If
End With
End Function
Function rq(str As String)
'自定义提取首段汉字后至日期前字符函数
With CreateObject("vbscript.RegExp")
.Global = ture
.IgnoreCase = False
.MultiLine = True
.Pattern = "{1,2}.+[\u4e00-\u9fa5]{2,3}"
If .test(str) Then
rq = .Execute(str)(0) '要匹配的目标(0)为匹配一次
Else
rq = "" '没有就返回空，防止出错
End If
End With
End Function
Function zjzf(str As String)
'自定义提取日期(带.)字符函数
With CreateObject("vbscript.RegExp")
.Global = ture
.IgnoreCase = False
.MultiLine = True
.Pattern = "{4}\.{1,2}\.{1,2}" '用d\不行
If .test(str) Then
zjzf = .Execute(str)(0) '要匹配的目标(0)为匹配一次
Else
zjzf = "" '没有就返回空，防止出错
End If
End With
End Function
Function hhz(str As String)
'自定义提取首段汉字后至日期前字符函数
With CreateObject("vbscript.RegExp")
.Global = ture
.IgnoreCase = False
.MultiLine = True
.Pattern = ".$" '所有字符的最后一位，这里与"[\u4e00-\u9fa5]$"同效
If .test(str) Then
hhz = .Execute(str)(0) '要匹配的目标(0)为匹配一次
Else
hhz = "" '没有就返回空，防止出错
End If
End With
End Function
Sub 提取4段内容()
'根据四段字符特点，定义4个函数，利用正则表达式一次性提取，比较清晰
Dim i As Integer
Range("b1:d6").ClearContents
For i = 1 To 5
Range("b" & i) = shz(Range("a" & i))
Range("c" & i) = rq(Range("a" & i))
Range("d" & i) = zjzf(Range("a" & i))
Range("e" & i) = hhz(Range("a" & i))
Next
End Sub
附上代码：