单元格中有文字和数字的，如何在数字下加下划线

ylq167

大神们帮忙：单元格中有文字和数字的，如何在数字下加下划线。

ylq167

大神们，原来那个版面位置发错了，换到这个版了，望能帮下忙！

hhjjpp

1. Private Sub CommandButton1_Click()
   
2. Dim reg, mh, mhk
   
3. Set reg = CreateObject("vbscript.regexp")
   
4. reg.Pattern = "\d+(.\d+)?" '[^%\d]?"
   
5. reg.Global = True
   
6. Set mh = reg.Execute([d3])
   
7. For Each mhk In mh
   
8.     [d3].Characters(Start:=mhk.FirstIndex + 1, Length:=mhk.Length).Font.Underline = xlUnderlineStyleSingle
   
9. Next
   
10. End Sub
    

复制代码

wj2368

。。。。。。。。。。。

hhjjpp

可惜Submatches没有FirstIndex和Length属性，无法用括号提取准确位置，只好if了！还好，楼主要求不高，如果再复杂一点真不知该怎么办！

1. Private Sub CommandButton1_Click()
   
2. Dim reg, mh, mhk
   
3. Set reg = CreateObject("vbscript.regexp")
   
4. reg.Pattern = "\d+(\.\d+)?" '[^%\d]?"
   
5. reg.Global = True
   
6. Set mh = reg.Execute([d3])
   
7. For Each mhk In mh
   
8.     If Mid([d3], mhk.FirstIndex + mhk.Length + 1, 1) <> "%" Then
   
9.        [d3].Characters(Start:=mhk.FirstIndex + 1, Length:=mhk.Length).Font.Underline = xlUnderlineStyleSingle
   
10.     End If
    
11. Next
    
12. End Sub
    

复制代码

ylq167

hhjjpp 发表于 2016-10-24 08:52

很好，可以解决我说的问题，不过要改多个单元格，这个好像不行啊，这代码里是特指一个单元格的对吧

hhjjpp

ylq167 发表于 2016-10-24 09:04
很好，可以解决我说的问题，不过要改多个单元格，这个好像不行啊，这代码里是特指一个单元格的对吧

没问题，你得有样本，总不能凭空搞吧？

ylq167

hhjjpp 发表于 2016-10-24 09:09
没问题，你得有样本，总不能凭空搞吧？

多个这种单元格，都要变，里面的数据是都不一样的

hhjjpp

ylq167 发表于 2016-10-24 10:25
多个这种单元格，都要变，里面的数据是都不一样的

1. Private Sub CommandButton1_Click()
   
2. Application.ScreenUpdating = False
   
3. Dim reg, mh, mhk, i%
   
4. Set reg = CreateObject("vbscript.regexp")
   
5. reg.Pattern = "\d+(\.\d+)?"                  '无法附加[^%\d]?进行限定；因为Submatches没有FirstIndex和Length属性，无法用括号提取准确位置
   
6. reg.Global = True
   
7. For i = 3 To [d13].End(xlUp).Row + 1
   
8.     Set mh = reg.Execute(Cells(i, 4))
   
9.     For Each mhk In mh
   
10.         If Mid(Cells(i, 4), mhk.FirstIndex + mhk.Length + 1, 1) <> "%" Then
    
11.            Cells(i, 4).Characters(Start:=mhk.FirstIndex + 1, Length:=mhk.Length).Font.Underline = xlUnderlineStyleSingle
    
12.         End If
    
13.     Next
    
14. Next
    
15. Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

ruixu2000

hhjjpp 发表于 2016-10-24 10:44

@hhjjpp老师 请您指教 谢谢   http://club.excelhome.net/thread-1430967-1-1.html