请大神帮忙编写VBA，减轻工作，谢谢！！

烟火孤星泪

请帮忙处理一下，谢谢

zhjlgaojuan

刚发出去就发现代码有问题,想修改结果还要等审核,这个服务器到底怎么了????

Sub test()
Dim MyDic As Object
Dim SourceArr As Variant
Set MyDic = CreateObject("scripting.dictionary")
SourceArr = Sheet1.UsedRange
For i = 2 To UBound(SourceArr)
    If SourceArr(i, 1) <> "" Then
        If Not MyDic.exists(SourceArr(i, 1)) Then Set MyDic(SourceArr(i, 1)) = CreateObject("scripting.dictionary")
            If Not MyDic(SourceArr(i, 1)).exists(SourceArr(i, 2)) Then Set MyDic(SourceArr(i, 1))(SourceArr(i, 2)) = CreateObject("scripting.dictionary"): MyDic(SourceArr(i, 1))(SourceArr(i, 2)) = ""
            MyDic(SourceArr(i, 1))(SourceArr(i, 2)) = MyDic(SourceArr(i, 1))(SourceArr(i, 2)) & IIf(MyDic(SourceArr(i, 1))(SourceArr(i, 2)) = "", "", "??") & SourceArr(i, 3)
            
    End If
Next
i = 2
Application.DisplayAlerts = False
For Each dic1 In MyDic.keys
    With Sheet2
        .Range("a" & i & ":a" & i + MyDic(dic1).Count - 1).Merge
        .Range("a" & i) = dic1
        j = i
        For Each dic2 In MyDic(dic1).keys
            .Range("b" & j) = dic2
            .Range("c" & j) = MyDic(dic1)(dic2)
            j = j + 1
        Next
    End With
     i = i + MyDic.Count
Next
Application.DisplayAlerts = True
End Sub

一指禅62

烟火孤星泪 发表于 2018-8-31 11:20
请帮忙处理一下，谢谢

1. Sub 按班级合并()
   
2.     Dim arr, i&, x&, d As Object, key$, Rng As Range
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheet1.Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         key = arr(i, 1) & "|" & arr(i, 2)
   
7.         If Not d.Exists(key) Then
   
8.             d(key) = arr(i, 3)
   
9.         Else
   
10.             d.Item(key) = d.Item(key) & "、" & arr(i, 3)
    
11.         End If
    
12.     Next
    
13.     Application.ScreenUpdating = False
    
14.     Application.DisplayAlerts = False
    
15.     Sheet2.Select
    
16.     Range("A2:C1000").UnMerge
    
17.     Range("A2:C1000").ClearContents
    
18.     Range("A2").Resize(d.Count, 3) = WorksheetFunction.Transpose(Array(d.keys, d.keys, d.items))
    
19.     Range("A:A").Replace "|*", ""
    
20.     Range("B:B").Replace "*|", ""
    
21.     x = 2
    
22.     For i = x To d.Count + 1
    
23.         If Cells(i, 1) <> Cells(i + 1, 1) Then
    
24.             Range("A" & x & ":A" & i).Merge
    
25.             x = i + 1
    
26.         End If
    
27.     Next
    
28.     Application.DisplayAlerts = True
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

一指禅62

烟火孤星泪 发表于 2018-8-31 11:20
请帮忙处理一下，谢谢

代码审核中。发附件

数据合并.rar (31.89 KB, 下载次数: 2)

2018-8-31 11:48 上传

点击文件名下载附件

一指禅62

我已上传，怎么看不见。

数据合并.rar (31.89 KB, 下载次数: 8)

2018-8-31 12:17 上传

点击文件名下载附件

烟火孤星泪

一指禅62 发表于 2018-8-31 12:17
我已上传，怎么看不见。

看到了，非常感谢

qj_xiele

Option Base 1
Sub TEST()
Dim Arr
Dim Dict_Count As Integer
Dim d As Object
Dim New_Table() As String
Set Dict = CreateObject("scripting.dictionary")
Sheets("数据表").Activate
Row_Count = Cells(Rows.Count, 1).End(3).Row
Read_Area = "A2:C" & Trim(Row_Count)
Arr = Range(Read_Area)
Sheets("生成合并表").Activate

For i = 1 To UBound(Arr)
    If Not Dict.exists(Arr(i, 1) & Arr(i, 2)) Then
        m = 1
        ReDim brr(1 To m)
    Else
        brr = Dict(Arr(i, 1) & Arr(i, 2))
        m = UBound(brr) + 1
        ReDim Preserve brr(1 To m)
    End If
    Dict(Arr(i, 1) & Arr(i, 2)) = brr
Next

K = Dict.Keys
Dict_Count = Dict.Count

ReDim New_Table(Dict_Count, 3)
For i = 0 To Dict.Count - 1
    Key = K(i)
    Pos = InStr(1, Key, "专业") + 1
    ZY = Mid(Key, 1, Pos)
    BJ = Mid(Key, Pos + 1, 100)
    String_Tmp = ""
    Count = 0
    For j = 1 To UBound(Arr)
        ZY1 = Arr(j, 1)
        BJ1 = Arr(j, 2)
        Stud_Name = Arr(j, 3)
        If Count = 0 And ZY = ZY1 And BJ = BJ1 Then
                Count = Count + 1
                String_Tmp = Stud_Name & "、"
        ElseIf Count > 0 And ZY = ZY1 And BJ = BJ1 Then
            Count = Count + 1
            String_Tmp = String_Tmp & Stud_Name & "、"
        End If
    Next
    New_Table(i + 1, 1) = ZY
    New_Table(i + 1, 2) = BJ
    New_Table(i + 1, 3) = String_Tmp
    String_Tmp_Len = Len(New_Table(i + 1, 3))
    New_Table(i + 1, 3) = Mid(New_Table(i + 1, 3), 1, String_Tmp_Len - 1)
Next
Write_Area = "A2:C" & Trim(Dict_Count + 1)
Range(Write_Area) = New_Table

End Sub

烟火孤星泪

qj_xiele 发表于 2018-8-31 14:43
Option Base 1
Sub TEST()
Dim Arr

你好，代码可以正常使用，能否再修改一下，生成的合并表中的每个专业的班级是否可以自动按升序进行排列，如下图
例如：