提取单元格内容，请大神帮助！！感激，在线等！

希望社会公平公正

ctrl+e 3行时间有点出入 不过大多数都ok

周俊合

Power Query解法
提取单元格内容.zip (15.85 KB, 下载次数: 110)

2021-10-31 12:26 上传

点击文件名下载附件
提取单元格内容.zip

热心市民武先生

不是针对你附件里的黄色部分的么?=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)
提取单元格内容-含代码.rar (18.61 KB, 下载次数: 51)

2021-10-31 12:26 上传

点击文件名下载附件
提取单元格内容-含代码.rar

没心没肺的垃圾真可怕

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 = "[0-9]{1,2}[A-Z].+[\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 = "[0-9]{4}\.[0-9]{1,2}\.[0-9]{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

阳光彩霞

附上代码：
两种方式提取单元格内容.rar (23.61 KB, 下载次数: 118)

2021-10-31 12:26 上传

点击文件名下载附件
两种方式提取单元格内容.rar