求助VBA解决方案，想不出来呀~~

sirsunny

请问除了公式，能不能用VBA达到如图所示的同样需求？
函数方法的公式实在是超长，看不懂，也想不出来：

1. SUBSTITUTE(VLOOKUP(D$2&"*",TRIM(MID(SUBSTITUTE($B3&CHAR(10)&D$2&"：",CHAR(10),REPT(" ",50)),{0;1;2;3}*50+1,50)),1,0),D$2&"：",)

复制代码

sirsunny

使用正则可以识别出汉字和英文，但是每个单元格中汉字的项目不同，不知道该怎么办了。难道还要再建个字典存放数据，然后填到各列中？看起来似乎有点麻烦。希望有人能给出更简洁的解决办法。

Jason_WangSS

1. Sub test()
   
2.     Dim brr()
   
3.     arr = Split(Sheet1.[b3], Chr(10))
   
4.     ReDim brr(1 To UBound(arr) + 1)
   
5.     For i = 1 To UBound(brr)
   
6.         brr(i) = Split(arr(i - 1), "：")
   
7.     Next
   
8.     brr = WorksheetFunction.Transpose(brr)
   
9. End Sub

复制代码

没完成，其他的自己弄一下

半百

Sub test()
arr = UsedRange
For i = 3 To UBound(arr)
    For J = 4 To 7
        S = arr(i, 2) & arr(2, J) & "： "
        A = Split(S, arr(2, J) & "：")
        B = Split(A(1), Chr(10))
        arr(i, J) = B(0)
    Next
Next
UsedRange = arr
End Sub

Tim-tao

提供一个思路吧，先用Split换行符把B列的分开，然后新增一个辅助的表存起来，再去匹配吧

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim sh As Worksheet, objDic As Object
   
5.     Dim lngRow As Long, lngCol As Long
   
6.     Dim arrSource As Variant, arrResult As Variant
   
7.     Dim strTemp As String, strSplit() As String, lngID As Long
   
8.     Dim strKey As String, strItem As String, strKI() As String
   
9.    
   
10.    
    
11.     Set sh = Sheets("Sheet1")
    
12.     Set objDic = CreateObject("Scripting.Dictionary")
    
13.    
    
14.     lngRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    
15.     arrSource = Sheet1.Range("A2:B" & lngRow)
    
16.    
    
17.     Sheet1.Range("D3:G" & lngRow).ClearContents
    
18.     arrResult = Sheet1.Range("D2:G" & lngRow)
    
19.     '设置标题字典
    
20.     For lngCol = LBound(arrResult, 2) To UBound(arrResult, 2)
    
21.         strKey = Trim(CStr(arrResult(1, lngCol)))
    
22.         If strKey <> "" Then objDic(strKey) = lngCol
    
23.     Next
    
24.    
    
25.     For lngRow = LBound(arrSource) + 1 To UBound(arrSource)
    
26.         strTemp = arrSource(lngRow, 2)
    
27.         strSplit = Split(strTemp, Chr(10))
    
28.         For lngID = LBound(strSplit) To UBound(strSplit)
    
29.             strKI = Split(strSplit(lngID), "：")
    
30.             If UBound(strKI) = 1 Then
    
31.                 strKey = Trim(strKI(0))
    
32.                 strItem = strKI(1)
    
33.                 If objDic.Exists(strKey) Then
    
34.                     lngCol = Val(objDic(strKey))
    
35.                     arrResult(lngRow, lngCol) = strItem
    
36.                 End If
    
37.             End If
    
38.         Next
    
39.     Next
    
40.    
    
41.     Sheet1.Range("D2").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult
    
42.     MsgBox "OK"
    
43. End Sub

复制代码

wodewan

根据TIM-TAO提醒，更正下（将M=1位置移动到循环外），大意了，多谢TIM-TAO的提醒。
Option Explicit
Sub test()
Dim d As Object, i&, j&, temp
Dim s, t, m&, arr, brr()
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion.Offset(1)
ReDim brr(1 To UBound(arr), 1 To 100)
m = 1
For i = 2 To UBound(arr) - 1
    arr(i, 2) = Replace(arr(i, 2), ":", "：")
    s = Split(arr(i, 2), Chr(10))
    For j = 0 To UBound(s)
        If InStr(s(j), "：") Then
            t = Split(s(j), "：")
            brr(1, 1) = arr(1, 1)
            brr(i, 1) = arr(i, 1)
            If Not d.exists(t(0)) Then
                m = m + 1:        d(t(0)) = m
                brr(1, m) = t(0):        brr(i, m) = t(1)
            Else
                brr(i, d(t(0))) = t(1)
            End If
        End If
    Next
Next
Range("D2").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

tspliu

Sub aa()
Set reg = CreateObject("Vbscript.Regexp")
    With reg
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^\n]+"
    End With
    For i = 3 To 4
   Set mc = reg.Execute(Cells(i, 2))
   For Each x In mc
  Select Case Left(x, 3)
  Case "?????"
  Cells(i, 4) = Replace(x, "?????", "", , , vbBinaryCompare)
  Case "????"
  Cells(i, 5) = Replace(x, "????", "", , , vbBinaryCompare)
  Case "????"
  Cells(i, 6) = Replace(x, "????", "", , , vbBinaryCompare)
  Case "????"
  Cells(i, 7) = Replace(x, "????", "", , , vbBinaryCompare)
  End Select
  Next
  Next
End Sub

sirsunny

高手如云啊！

Tim-tao

wodewan 发表于 2019-11-6 16:26
Option Explicit

Sub test()

此方法是否要保证第一个出现的内容，也就是B3单元格必须是所有出现的键值对名称，比如表格如果B3和B4单元格内容互换那么运行就不对了