[已解决]【VBA】字符串中提取数字外加格式转换和分列，求老师指教

庆生妈妈

求老师指教，非常感谢
做了一个问卷调查，但是回收的问卷答案在视力一列格式参差不齐，无法直接用于数据分析软件。VBA初学现在是满头雾水，求大神指点
具体例子可见附件。
1. 左右眼视力目前在一个列，想分成两列，如：4.74.6直接分成两列，
2. 有的中间会掺杂汉字或特殊字符或空格，需要剔除掉；
3. 整体使用五分法，如果视力为小于2的小数需按附图标准转换成五分法；
4. 写的眼镜度数（数字大于20）和纯汉字（如不清楚）的都置为空；
5. 只写一个数字（如3.0）在经过上述处理后复制给另一列
要求啰里啰嗦，感觉像一个毛线团无从下手OTZ，希望老师指点一下，万分感谢

最佳答案

月排行榜 / 总排行榜

grf1973

2017-3-31 11:00

1. Sub 处理()
   
2.     xsf = Array("0.1", "0.2", "0.3", "0.4", "0.5", "0.6", "0.8", "1.0", "1.2", "1.5", "2.0")    '小数法
   
3.     wff = Array("4.0", "4.3", "4.5", "4.6", "4.7", "4.8", "4.9", "5.0", "5.1", "5.2", "5.3") '五分法
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 0 To UBound(xsf): d(xsf(i)) = wff(i): Next    '建立小数法和五分法的对应关系
   
6.    
   
7.     arr = Sheet1.[a1].CurrentRegion
   
8.     With CreateObject("vbscript.regexp")
   
9.         .Global = True
   
10.         .Pattern = "\d\.\d"     '找出a.b类型的数值
    
11.         For j = 1 To 4
    
12.             If j <> 2 Then    '第2列不判断
    
13.                 For i = 2 To UBound(arr)
    
14.                     x = arr(i, j)
    
15.                     x = Replace(Replace(Replace(x, ",", "."), "·", "."), "，", ".")   '转化不规范格式
    
16.                     Set ma = .Execute(x)
    
17.                     If ma.Count > 0 Then     '如果存在a.b格式
    
18.                         x1 = ma(0): x2 = ma(ma.Count - 1)   '提取数值
    
19.                         If d.exists(x1) Then x1 = d(x1)    '取对应关系
    
20.                         If d.exists(x2) Then x2 = d(x2)
    
21.                         arr(i, j) = x1 & " " & x2    '显示结果
    
22.                     Else
    
23.                         arr(i, j) = ""   '如果不存在，清空
    
24.                     End If
    
25.                 Next
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Sheet2.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 处理()
   
2.     xsf = Array("0.1", "0.2", "0.3", "0.4", "0.5", "0.6", "0.8", "1.0", "1.2", "1.5", "2.0")    '小数法
   
3.     wff = Array("4.0", "4.3", "4.5", "4.6", "4.7", "4.8", "4.9", "5.0", "5.1", "5.2", "5.3") '五分法
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 0 To UBound(xsf): d(xsf(i)) = wff(i): Next    '建立小数法和五分法的对应关系
   
6.    
   
7.     arr = Sheet1.[a1].CurrentRegion
   
8.     With CreateObject("vbscript.regexp")
   
9.         .Global = True
   
10.         .Pattern = "\d\.\d"     '找出a.b类型的数值
    
11.         For j = 1 To 4
    
12.             If j <> 2 Then    '第2列不判断
    
13.                 For i = 2 To UBound(arr)
    
14.                     x = arr(i, j)
    
15.                     x = Replace(Replace(Replace(x, ",", "."), "·", "."), "，", ".")   '转化不规范格式
    
16.                     Set ma = .Execute(x)
    
17.                     If ma.Count > 0 Then     '如果存在a.b格式
    
18.                         x1 = ma(0): x2 = ma(ma.Count - 1)   '提取数值
    
19.                         If d.exists(x1) Then x1 = d(x1)    '取对应关系
    
20.                         If d.exists(x2) Then x2 = d(x2)
    
21.                         arr(i, j) = x1 & " " & x2    '显示结果
    
22.                     Else
    
23.                         arr(i, j) = ""   '如果不存在，清空
    
24.                     End If
    
25.                 Next
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Sheet2.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
30. End Sub
    

复制代码

庆生妈妈

grf1973 发表于 2017-3-31 11:00

真的太感谢了！使用过了成功的完成了数据格式整理~~解答的真是又快又好！
不过还有一个问题请教。如果不建立sheet2，而是在原有的数据列后面新插入列放入处理后的数据，方便观察有无疏漏，该怎么修改代码呢？