请教多条学历信息合并到一个单元格

木图天

请教如何 按顺序合并 员工的学历 详情信息 到一个单元格？

limonet

函数嵌套：=SUBSTITUTE(TEXTJOIN(" ",,SORT(FILTER(C:H,B:B=I2),1,1)),"位 ","位"&CHAR(10))

小凡、、、

乱写一个吧

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:h" & r)
   
9.         For i = 1 To UBound(arr)
   
10.             arr(i, 3) = CDate(arr(i, 3))
    
11.             arr(i, 4) = CDate(arr(i, 4))
    
12.         Next
    
13.         .Range("a2:h" & r) = arr
    
14.         .Range("a2:h" & r).Sort key1:=.Range("b2"), order1:=xlAscending, key2:=.Range("c2"), order2:=xlAscending, Header:=xlNo
    
15.         arr = .Range("a2:h" & r)
    
16.         For i = 1 To UBound(arr)
    
17.             If Not d.exists(arr(i, 2)) Then
    
18.                 ReDim brr(1 To 2)
    
19.                 brr(1) = arr(i, 2)
    
20.             Else
    
21.                 brr = d(arr(i, 2))
    
22.             End If
    
23.             brr(2) = brr(2) & vbLf & arr(i, 3) & Space(1) & arr(i, 4) & Space(1) & arr(i, 5) & Space(1) & arr(i, 6) & Space(1) & arr(i, 7) & Space(1) & arr(i, 8)
    
24.             d(arr(i, 2)) = brr
    
25.         Next
    
26.         ReDim crr(1 To d.Count, 1 To 2)
    
27.         m = 0
    
28.         For Each aa In d.keys
    
29.             brr = d(aa)
    
30.             If Len(brr(2)) <> 0 Then
    
31.                 brr(2) = Mid(brr(2), 2)
    
32.             End If
    
33.             m = m + 1
    
34.             For j = 1 To UBound(brr)
    
35.                 crr(m, j) = brr(j)
    
36.             Next
    
37.         Next
    
38.         .Range("a2:h" & r).Sort key1:=.Range("a2"), order1:=xlAscending, Header:=xlNo
    
39.         
    
40.     End With
    
41.     With Worksheets("sheet2")
    
42.         .UsedRange.Offset(1, 0).Clear
    
43.         .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
44.     End With
    
45.             
    
46. End Sub
    

复制代码

chxw68

参与一下。

yes_cn

这个可以用

Qs18

1. Sub qs()
   
2. Dim arr, i, dic As Object, m, rw
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion.Value
   
5. ReDim brr(1 To UBound(arr), 1 To 2)
   
6. For i = 2 To UBound(arr)
   
7.     s = arr(i, 2)
   
8.     t = ""
   
9.     If Not dic.exists(s) Then
   
10.         m = m + 1
    
11.         dic(s) = m
    
12.         brr(m, 1) = s
    
13.         For j = 3 To UBound(arr, 2)
    
14.             t = t & " " & arr(i, j)
    
15.         Next
    
16.         brr(m, 2) = Mid(t, 2)
    
17.     Else
    
18.         rw = dic(s)
    
19.         For j = 3 To UBound(arr, 2)
    
20.             t = t & " " & arr(i, j)
    
21.         Next
    
22.         t = Mid(t, 2)
    
23.         brr(rw, 2) = brr(rw, 2) & Chr(10) & t
    
24.     End If
    
25. Next
    
26. Sheet1.Range("j24").Resize(m, 2) = brr
    
27. Set dic = Nothing
    
28. End Sub
    

复制代码

Qs18

试试...........

Qs18

试试........................

cnmlgb9998

这样？？？？？？？？？？？？？？


公式完全可以解决