[已解决]求字符转换的代码

sanfuhai

试过公式，转换的不准确，求代码。详情请见附件 求字符转换代码.rar (8.93 KB, 下载次数: 6)

2022-2-9 02:02 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

林木水

2022-2-10 15:31

1. Option Explicit
   
2. Option Compare Text
   
3. Sub 匹配()
   
4. Dim arr, h As Integer, i As Integer, brr(), crr()
   
5. h = Sheet1.Cells(Rows.Count, "L").End(xlUp).Row
   
6. If h = 1 Then End
   
7.     arr = Sheet1.Range("l6:l" & h)
   
8.     For i = 1 To UBound(arr)
   
9.         ReDim Preserve brr(1 To i)
   
10.         ReDim Preserve crr(1 To i)
    
11.         brr(i) = VBA.Split(arr(i, 1), "/")(0)
    
12.         crr(i) = VBA.Split(arr(i, 1), "/")(1)
    
13.     Next i
    
14.     Dim drr, j As Integer, f As Integer
    
15.     drr = Sheet1.Range("e6:e" & Sheet1.Cells(Rows.Count, "e").End(xlUp).Row)
    
16.     For i = 1 To UBound(drr)
    
17.         f = 0
    
18.         For j = 1 To UBound(arr)
    
19.             If drr(i, 1) = brr(j) Or drr(i, 1) = crr(j) Then
    
20.                 f = 1
    
21.                 drr(i, 1) = arr(j, 1)
    
22.                 Exit For
    
23.             End If
    
24.         Next j
    
25.         If f = 0 Then drr(i, 1) = "请检查命名是否规范"
    
26.     Next i
    
27.     Sheet1.Range("G6:G" & Sheet1.Cells(Rows.Count, "e").End(xlUp).Row) = drr
    
28. End Sub
    

复制代码

此代码需要注意事项：
1.E列的命名跟L列的命名要规范：E列使用括号跟L列要么全部是英文要么全部是中文
2.L列英文和后面中文描述，需要全部以“/”斜杠分开，不要有些斜杠在中间
3.因为此代码是完全匹配，近似匹配的显示结果为“请检查命名是否规范”，避免出错，药品还是要严谨
4.不需要区分大小写字母，E列或者L列前后不要有空格

跳转到最佳答案楼层

砂海

在 别人 看来 ,
是要 从E列 模糊查找 到 L列的精确值

药物 不容含糊 ,
建议建立精确对照表, 才是可靠的方法

ahn

砂海 发表于 2022-2-9 10:40
在 别人 看来 ,
是要 从E列 模糊查找 到 L列的精确值

建立精确对照表是最好的方法，简单、快速、灵活、精确。

谁懂我的心

1、G6公式改为：=IFERROR(LOOKUP(1,0/(E6=MID(L:L,FIND("/",L:L)+1,99)),L:L),"")。2、附件表中E列的括号是全角字符，L列的括号是半角字符，为了不管是全角还是半角都能匹配，那么G6公式可改为如下：

=IFERROR(LOOKUP(1,0/(SUBSTITUTE(SUBSTITUTE(E6,"（","("),"）",")")=MID(L:L,FIND("/",L:L)+1,99)),L:L),"")

3、第2点中的公式是强制把全角括号字符改为半角括号字符后再匹配；这样更改后，不管E列是中的括号输入的是全角还是半角，都是以半角字符模式与L列匹配，这就要求L列的括号必须都是半角括号。可如下操作：全选L列，替换全角"（"为半角"("，替换全角"）"为半角")"即可。

林木水

1. Sub 字符转换()
   
2. Dim arr, i As Integer, brr()
   
3.     arr = Sheet1.Range("e6:l10")
   
4.     For i = 1 To UBound(arr)
   
5.         ReDim Preserve brr(1 To i)
   
6.         brr(i) = arr(i, UBound(arr, 2))
   
7.     Next i
   
8.     Sheet1.Range("h6").Resize(UBound(arr)) = Application.Transpose(brr)
   
9. End Sub
   
10. 
    

复制代码

要这样？需求描述得不是很明确

sanfuhai

林木水 发表于 2022-2-9 14:27
要这样？需求描述得不是很明确

大致是这样的，重新上传了一个附件，请大神帮忙 求字符转换代码.rar (9.54 KB, 下载次数: 3)

2022-2-9 21:32 上传

点击文件名下载附件

林木水

1. Option Explicit
   
2. Option Compare Text
   
3. Sub 匹配()
   
4. Dim arr, h As Integer, i As Integer, brr(), crr()
   
5. h = Sheet1.Cells(Rows.Count, "L").End(xlUp).Row
   
6. If h = 1 Then End
   
7.     arr = Sheet1.Range("l6:l" & h)
   
8.     For i = 1 To UBound(arr)
   
9.         ReDim Preserve brr(1 To i)
   
10.         ReDim Preserve crr(1 To i)
    
11.         brr(i) = VBA.Split(arr(i, 1), "/")(0)
    
12.         crr(i) = VBA.Split(arr(i, 1), "/")(1)
    
13.     Next i
    
14.     Dim drr, j As Integer, f As Integer
    
15.     drr = Sheet1.Range("e6:e" & Sheet1.Cells(Rows.Count, "e").End(xlUp).Row)
    
16.     For i = 1 To UBound(drr)
    
17.         f = 0
    
18.         For j = 1 To UBound(arr)
    
19.             If drr(i, 1) = brr(j) Or drr(i, 1) = crr(j) Then
    
20.                 f = 1
    
21.                 drr(i, 1) = arr(j, 1)
    
22.                 Exit For
    
23.             End If
    
24.         Next j
    
25.         If f = 0 Then drr(i, 1) = "请检查命名是否规范"
    
26.     Next i
    
27.     Sheet1.Range("G6:G" & Sheet1.Cells(Rows.Count, "e").End(xlUp).Row) = drr
    
28. End Sub
    

复制代码

此代码需要注意事项：
1.E列的命名跟L列的命名要规范：E列使用括号跟L列要么全部是英文要么全部是中文
2.L列英文和后面中文描述，需要全部以“/”斜杠分开，不要有些斜杠在中间
3.因为此代码是完全匹配，近似匹配的显示结果为“请检查命名是否规范”，避免出错，药品还是要严谨
4.不需要区分大小写字母，E列或者L列前后不要有空格