WORD中的元变成万元？希望哪个网友再补充一个excel版的代码（补充要求附件在17楼）

limonet

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Columns.Count > 1 Then Exit Sub
    Dim Arr(1 To 9999, 1 To 1), Ms As Object, j%, C
    With CreateObject("vbscript.regexp")
        .Pattern = "[0-9,]+.[0-9]+(?=元)"
        .Global = True
        For Each C In Target
            j = j + 1
            Arr(j, 1) = C.Text
            Set Ms = .Execute(Arr(j, 1))
            For i = Ms.Count - 1 To 0 Step -1
                Arr(j, 1) = Application.Replace(Arr(j, 1), Ms(i).FirstIndex + 1, Ms(i).Length, Format(Ms(i) / 10000, "#,##0.00万"))
            Next i
        Next C
    End With
   Target(1).Offset(0, 1).Resize(j) = Arr
End Sub

limonet

关键字：selectionchange

limonet

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Columns.Count > 1 Then Exit Sub
    Dim Arr(1 To 9999, 1 To 1), Ms As Object, j%, C
    With CreateObject("vbscript.regexp")
        .Pattern = "[0-9,]+\.[0-9]+(?=元)"
        .Global = True
        For Each C In Target
            j = j + 1
            Arr(j, 1) = C.Text
            Set Ms = .Execute(Arr(j, 1))
            For i = Ms.Count - 1 To 0 Step -1
                Arr(j, 1) = Application.Replace(Arr(j, 1), Ms(i).FirstIndex + 1, Ms(i).Length, Format(Ms(i) / 10000, "#,##0.00万"))
            Next i
        Next C
    End With
   Target(1).Resize(j) = Arr
End Sub

limonet

去掉OFFSET，原内容更新。

limonet

去掉工作表函数。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Columns.Count > 1 Then Exit Sub
    Dim Arr(1 To 9999, 1 To 1), Ms As Object, j%, C
    With CreateObject("vbscript.regexp")
        .Pattern = "[0-9,]+\.[0-9]+(?=元)"
        .Global = True
        For Each C In Target
            j = j + 1
            Arr(j, 1) = C.Text
            Set Ms = .Execute(Arr(j, 1))
            For i = Ms.Count - 1 To 0 Step -1
                Arr(j, 1) = Replace(Arr(j, 1), Ms(i), Format(Ms(i) / 10000, "#,##0.00万"))
            Next i
        Next C
    End With
   Target(1).Resize(j) = Arr
End Sub

tcdatongye

wshcw 发表于 2024-9-17 19:06
希望哪个网友再补充一个excel版的代码
将元转换为万元并保留两位小数

1. Sub 转换()
   
2. Set reg = VBA.CreateObject("vbscript.regexp")
   
3. n = Range("a1").CurrentRegion.Rows.Count
   
4. With reg
   
5.   .Global = True
   
6.   .Pattern = "(.*?)([\d,.]+(?=元)|$)"
   
7.   For i = 2 To n
   
8.     Set pat = .Execute(Cells(i, 1).Text)
   
9.     For Each subpat In pat
   
10.       t1 = subpat.submatches(1)
    
11.       If t1 <> "" Then t1 = Format(t1 / 10000, "#,##0.00万")
    
12.       t = t & subpat.submatches(0) & t1
    
13.     Next
    
14.     Cells(i, 2) = t: t = ""
    
15.   Next i
    
16. End With
    
17. End Sub

复制代码

tcdatongye

tcdatongye 发表于 2024-9-19 20:06

1. Sub aa()
   
2. On Error Resume Next
   
3. Set Rng = Application.InputBox(prompt:="可选择多个区域如：$B$2,$B$4", Title:="区域选择", Type:=8)
   
4. If Err.Number > 0 Then Exit Sub
   
5. Set arrlist = VBA.CreateObject("system.collections.arraylist")
   
6. For Each subrng In Rng
   
7.   arrlist.Add 转换(subrng)
   
8. Next
   
9. Arr = arrlist.toArray
   
10. 10:
    
11. Set Rng = Application.InputBox(prompt:="以单列放置数据", Title:="存放地点", Type:=8)
    
12. If Err.Number > 0 Then MsgBox "选择错误!": GoTo 10
    
13. Rng.Cells(1).Resize(arrlist.Count) = Application.Transpose(Arr)
    
14. End Sub
    
15. Function 转换(tag)
    
16. Set reg = VBA.CreateObject("vbscript.regexp")
    
17. With reg
    
18.   .Global = True
    
19.   .Pattern = "(.*?)([\d,.]+(?=元)|$)"
    
20.     Set pat = .Execute(tag.Text)
    
21.     For Each subpat In pat
    
22.       t1 = subpat.submatches(1)
    
23.       If t1 <> "" Then t1 = Format(t1 / 10000, "#,##0.00万")
    
24.       t = t & subpat.submatches(0) & t1
    
25.     Next
    
26.     转换 = t
    
27. End With
    
28. End Function

复制代码

wshcw

tcdatongye 发表于 2024-9-20 19:13

代码完美，这才是我需要的收藏的。