[已解决]没有相同字母才合并,100*100*100*100，公式太多，求来一VB码

love586

D4=B4合并D2,
E5=B5合并E2，
...等等。也就是，B6合并F2, 这两个单元格同时都有值（文本），有对应才合并。
合并条件：没有相同字母才合并，(2ABJ)(2CDK)  这样才可以。
不能出现两个字母相同。
满足合并条件才显示，否为空。
B4-B列未知
D3-横向未知
输出：D4=($B4&D$2)没有相同字母才合并,否为空。
100*100*100*100，公式太多，求来一VB码

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2021-11-23 20:01

1. Sub test()
   
2. Dim arr1, arr2, arrRst$(), i&, j&, k&, b As Boolean, sTmp$
   
3. arr1 = Range("b4:b" & Cells(Rows.Count, 2).End(3).Row)
   
4. arr2 = [d2].Resize(, Cells(2, Columns.Count).End(1).Column - 3)
   
5. ReDim arrRst(1 To UBound(arr1), 1 To UBound(arr2, 2))
   
6. For i = 1 To UBound(arr1)
   
7.   For j = 1 To UBound(arr2, 2)
   
8.     b = False
   
9.     For k = 2 To Len(arr1(i, 1)) - 1
   
10.       sTmp = Mid(arr1(i, 1), k, 1)
    
11.       If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), Mid(arr1(i, 1), k, 1)) Then b = True: Exit For
    
12.     Next
    
13.     If b = False Then arrRst(i, j) = arr1(i, 1) & arr2(1, j)
    
14.   Next j
    
15. Next i
    
16. [d4].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
    
17. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub test()
   
2. Dim arr1, arr2, arrRst$(), i&, j&, k&, b As Boolean, sTmp$
   
3. arr1 = Range("b4:b" & Cells(Rows.Count, 2).End(3).Row)
   
4. arr2 = [d2].Resize(, Cells(2, Columns.Count).End(1).Column - 3)
   
5. ReDim arrRst(1 To UBound(arr1), 1 To UBound(arr2, 2))
   
6. For i = 1 To UBound(arr1)
   
7.   For j = 1 To UBound(arr2, 2)
   
8.     b = False
   
9.     For k = 2 To Len(arr1(i, 1)) - 1
   
10.       sTmp = Mid(arr1(i, 1), k, 1)
    
11.       If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), Mid(arr1(i, 1), k, 1)) Then b = True: Exit For
    
12.     Next
    
13.     If b = False Then arrRst(i, j) = arr1(i, 1) & arr2(1, j)
    
14.   Next j
    
15. Next i
    
16. [d4].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
    
17. End Sub

复制代码

心正意诚身修

大灰狼1976 发表于 2021-11-23 20:01

妈呀。附件都没有你就整出来了。

大灰狼1976

心正意诚身修 发表于 2021-11-23 20:09
妈呀。附件都没有你就整出来了。

有附件的，在另外一个论坛上

love586

大灰狼1976 发表于 2021-11-23 20:01

谢谢，大佬

大灰狼1976

If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), Mid(arr1(i, 1), k, 1)) Then b = True: Exit For
这句后面忘记修改成sTmp了，不过不影响使用。
If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), sTmp) Then b = True: Exit For

love586

大灰狼1976 发表于 2021-11-23 20:12
If Not IsNumeric(sTmp) Then If InStr(arr2(1, j), Mid(arr1(i, 1), k, 1)) Then b = True: Exit For
这 ...

知道了 ，谢谢哈

大灰狼1976

love586 发表于 2021-11-23 20:15
知道了 ，谢谢哈

不必客气哈