[已解决]VBA求助

wxfwxj

新建 Microsoft Excel 工作表.zip (7.14 KB, 下载次数: 24)

2013-10-9 14:46 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-10-9 16:12

1. Sub 整理()
   
2.     Dim arr, arr2
   
3.     Dim strKey$
   
4.     Dim i&, j&
   
5.     Dim d As Object
   
6.    
   
7.     arr = Sheet2.Range("a1").CurrentRegion.Value
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     For i = LBound(arr) + 1 To UBound(arr)
   
10.         If Len(arr(i, 1)) Then strKey = arr(i, 1)
    
11.         If Len(arr(i, 2)) Then d(strKey) = d(strKey) & arr(i, 2) & "#"
    
12.     Next
    
13.    
    
14.     If d.Count = 0 Then Exit Sub
    
15.     Worksheets.Add
    
16.    
    
17.     arr2 = d.keys
    
18.     Application.ScreenUpdating = False
    
19.     For i = 1 To d.Count
    
20.         j = (i - 1) * 3 + 1
    
21.         With Cells(2, j)
    
22.             .Value = arr2(i - 1)
    
23.             .Offset(1).Value = "姓名"
    
24.             .Resize(, 3).HorizontalAlignment = xlCenterAcrossSelection
    
25.             arr = WorksheetFunction.Transpose(Split(d(arr2(i - 1)), "#"))
    
26.             With .Offset(2).Resize(UBound(arr) - 1)
    
27.                 .Value = arr
    
28.                 .Interior.ColorIndex = 6
    
29.             End With
    
30.         End With
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK"
    
34. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

你都知道合并单元格够坑人的了，自己输出还要用合并单元格。

wxfwxj

希望各位前辈帮忙

hwc2ycy

其实用技巧应该也是可以的。如果实际应用中组的数量大于2个的话，那又不一样了。

wangzan

Public Sub 测试()
Dim h As Integer, ra As Range, st1 As String, s1 As Integer, x As Integer, y As Integer
st1 = [a2]
Set ra = Sheets("Sheet2").[a:a]
h = Application.Match(st1, ra, 0)
s1 = Sheets("Sheet2").Range("A" & h).MergeArea.Count
y = 3
For x = h To h + s1 - 1
If Sheets("Sheet2").Cells(x, 2) <> "" Then
Cells(y + 1, 1) = Sheets("Sheet2").Cells(x, 2)
y = y + 1
End If
Next
End Sub

以第一组为列，自己再加吧

wxfwxj

wangzan 发表于 2013-10-9 15:53
Public Sub 测试()
Dim h As Integer, ra As Range, st1 As String, s1 As Integer, x As Integer, y As I ...

不要每次都运行，可以吗，
就是说表2中姓名增加了表3中也自动增加不要去再运行宏

hwc2ycy

1. Sub 整理()
   
2.     Dim arr, arr2
   
3.     Dim strKey$
   
4.     Dim i&, j&
   
5.     Dim d As Object
   
6.    
   
7.     arr = Sheet2.Range("a1").CurrentRegion.Value
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     For i = LBound(arr) + 1 To UBound(arr)
   
10.         If Len(arr(i, 1)) Then strKey = arr(i, 1)
    
11.         If Len(arr(i, 2)) Then d(strKey) = d(strKey) & arr(i, 2) & "#"
    
12.     Next
    
13.    
    
14.     If d.Count = 0 Then Exit Sub
    
15.     Worksheets.Add
    
16.    
    
17.     arr2 = d.keys
    
18.     Application.ScreenUpdating = False
    
19.     For i = 1 To d.Count
    
20.         j = (i - 1) * 3 + 1
    
21.         With Cells(2, j)
    
22.             .Value = arr2(i - 1)
    
23.             .Offset(1).Value = "姓名"
    
24.             .Resize(, 3).HorizontalAlignment = xlCenterAcrossSelection
    
25.             arr = WorksheetFunction.Transpose(Split(d(arr2(i - 1)), "#"))
    
26.             With .Offset(2).Resize(UBound(arr) - 1)
    
27.                 .Value = arr
    
28.                 .Interior.ColorIndex = 6
    
29.             End With
    
30.         End With
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK"
    
34. End Sub

复制代码

hwc2ycy

结果在新表中输出，自己根据情况来改。

wxfwxj

hwc2ycy 发表于 2013-10-9 16:12

运行后就自动插入了一个工作表

hwc2ycy

VBA-字典 合并单元格-整理 新建 Microsoft Excel 工作表.rar (15.02 KB, 下载次数: 3)

2013-10-9 16:45 上传

点击文件名下载附件