请教老师：如何提取前三句话的第一个汉字？

zainan0810

请教老师：如何提取前三句话中，每句话的第一个汉字。并将这个汉字分别放在A、B、C列中。具体见上面例子。
注：1、被标点符号（，。、；）隔开的，就算一句话；2、不够三句话的，有几句就提几句；3、《》（）%等，不能按汉字处理，如果这条不能实现，我可以对文字进行处理，使每句话的第一个字都是汉字。 提取前三句话的第一个汉字.rar (6.78 KB, 下载次数: 8)

2019-10-20 17:14 上传

点击文件名下载附件

liulang0808

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     With CreateObject("vbscript.regexp")
   
4.         .Pattern = "[\u4e00-\u9fff]"
   
5.         For j = 1 To Cells(Rows.Count, 4).End(3).Row
   
6.             str1 = Cells(j, 4)
   
7.             For i = 1 To Len("，。、；")
   
8.                 str1 = Replace(str1, Mid("，。、；", i, 1), "@@##$")
   
9.             Next i
   
10.             arr = Split("@@##$" & str1, "@@##$")
    
11.             c = 1
    
12.             For i = 1 To UBound(arr)
    
13.                 If .test(arr(i)) Then
    
14.                     Cells(j, c) = .Execute(arr(i))(0)
    
15.                     c = c + 1
    
16.                     If c = 4 Then Exit For
    
17.                 End If
    
18.             Next i
    
19.         Next j
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

liulang0808

附件代码供参考。。。。

liuxi001

1. Sub 提取()
   
2.     bths = 0 '标题行数
   
3.     sjlh = "d" '数据列号
   
4.     sjzhs = Cells.SpecialCells(xlCellTypeLastCell).Row - bths '数据总行数
   
5.     ar = Cells(bths + 1, sjlh).Resize(sjzhs) '数据源
   
6.     ReDim cr(1 To UBound(ar), 1 To 3) '结果数组
   
7.     With CreateObject("vbscript.regexp")
   
8.         .Global = True '全部查找
   
9.         .Pattern = "([\u4e00-\u9fff]).+?[，。、；]"
   
10.         For i = 1 To UBound(ar)
    
11.             s = ar(i, 1) & "。"
    
12.             If .test(s) Then
    
13.                 Set mh = .Execute(s)
    
14.                 For y = 1 To IIf(mh.Count < 3, mh.Count, 3)
    
15.                     cr(i, y) = mh(y - 1).submatches(0)
    
16.                 Next
    
17.             End If
    
18.         Next
    
19.     End With
    
20.     With Range("a1") '输出
    
21.         .Resize(Rows.Count - bths, UBound(cr, 2)).ClearContents
    
22.         .Resize(UBound(cr), UBound(cr, 2)) = cr
    
23.     End With
    
24. End Sub

复制代码

kevinchengcw

试下

liangmutou01

Sub cs()
  Application.ScreenUpdating = False
  h = [d65536].End(3).Row
  With Range("d1:d" & h)
    .Copy [g1]
    .Replace "，", "~"
    .Replace "。", "~"
    .Replace "、", "~"
    .Replace "；", "~"
    .Replace "《", ""
    .Replace "》", ""
    .Replace "（", ""
    .Replace "）", ""
    .Replace "%", ""
  End With
  For Each n In Range("d1:d" & h)
    js = Split(n, "~")
    i = UBound(js)
    If i >= 2 Then n.Offset(0, -3) = Left(js(0), 1): n.Offset(0, -2) = Left(js(1), 1): n.Offset(0, -1) = Left(js(2), 1)
    If i = 1 Then n.Offset(0, -3) = Left(js(0), 1): n.Offset(0, -2) = Left(js(1), 1)
    If i = 0 Then n.Offset(0, -3) = Left(js(0), 1)
  Next n
  Range("g1:g" & h).Copy [d1]
  Range("g1:g" & h).ClearContents
  Application.ScreenUpdating = True
End Sub

liangmutou01

把程序文件发给你。

zainan0810

liulang0808 发表于 2019-10-20 18:53
附件代码供参考。。。。

谢谢版主大人一直以来对我的厚爱！昨天在单位值班，回复晚了，不好意思。

zainan0810

liuxi001 发表于 2019-10-20 19:19

谢谢老师对我的指点！昨天在单位值班，回复晚了，不好意思。

zainan0810

liangmutou01 发表于 2019-10-20 20:27
Sub cs()
  Application.ScreenUpdating = False
  h = [d65536].End(3).Row

谢谢liangmutou老师的指点！这几天忙了点，回复晚了，请原谅！