excel里宏及VBA问题

Question

在excel里边有两列，分别是学生和专业，怎么把专业相同的学生放在同一个单元格里，到最后只剩下不重复的专业。学生人数巨大，怎么用宏来实现这个功能呢？代码是怎样的？

Answer 1

示例工作表数据图片如下:

代码如下:

Sub ZL()
Dim ZYDIC, Rng As Range
Set ZYDIC = CreateObject("Scripting.Dictionary")
For Each Rng In Range("B:B")
    If Rng <> "" Then
        ZYDIC(Rng.Value) = ZYDIC(Rng.Value) & " " & Rng.Offset(0, -1).Value
    Else
        Exit For
    End If
Next
Range("D1").Resize(ZYDIC.Count, 1) = WorksheetFunction.Transpose(ZYDIC.keys)
Range("C1").Resize(ZYDIC.Count, 1) = WorksheetFunction.Transpose(ZYDIC.items)
End Sub

追问

你的解答非常好，其实我简化了原来的题目，原题目要求如图所示，把相同零件的产品型号归纳到同一个单元格里，后面的数量和层数和第一次出现的零件相同即可，求大神再写一次程序，感激不尽

追答Sub ZL()
Dim ZYDIC, SLDIC, Arr(), Rng As Range
Set ZYDIC = CreateObject("Scripting.Dictionary")
Set SLDIC = CreateObject("Scripting.Dictionary")
For Each Rng In Range("B:B")
    If Rng <> "" Then
        ZYDIC(Rng.Value) = ZYDIC(Rng.Value) & " " & Rng.Offset(0, -1).Value
        If Not SLDIC.exists(Rng.Value) Then
            SLDIC(Rng.Value) = Rng.Offset(0, 1).Value
            n = n + 1
            ReDim Preserve Arr(1 To n)
            Arr(n) = Rng.Offset(0, 2).Value
        End If
    Else
        Exit For
    End If
Next
Range("F1").Resize(ZYDIC.Count, 1) = WorksheetFunction.Transpose(ZYDIC.keys)
Range("E1").Resize(ZYDIC.Count, 1) = WorksheetFunction.Transpose(ZYDIC.items)
Range("G1").Resize(SLDIC.Count, 1) = WorksheetFunction.Transpose(SLDIC.items)
Range("H1").Resize(n, 1) = WorksheetFunction.Transpose(Arr)
End Sub

追问

大神啊，不好意思，你这个代码确实是可以运行的。但今天我回去看了一下表，又出问题了。是这样的有些产品型号和零件连续出现两次或两次以上，如图产品型号A在同一单元格出现了三次，我只想让他出现一次？求大神再次出手，感激不尽！！！！！

追答

竟然有字数限制 代码贴不完整只好给你发成附件了.

Answer 2

假设A2：B10000是数据源，A列为专业，B列为学生，则在D2输入

=IF(AND(COUNTIF(D$1:D1,A$2:A$10000)),"",INDEX(A$2:A$10000,MATCH(,COUNTIF(D$1:D1,A$2:A$10000),),))

按【CTRL+SHIFT+回车】后下拉填充公式

你所说的将同一专业的学生放在一个单元格中，这既不符合数据管理的规范，EXCEL普通函数也无法实现，且表格美观也受影响，所以，建议还是一个单元格放一个学生，便于后续的统计等。

E2输入

=IF($D2="","",IF(COLUMN(A1)<=COUNTIF($A:$A,$D2),INDEX($B$2:$B$10000,,SMALL(IF($A$2:$A$10000=$D2,ROW($1:$9999),4^4),COLUMN(A1)),""))

按【CTRL+SHIFT+回车】后，向右拉再向下拉填充公式即可

本回答被网友采纳

Answer 3

可以将专业排序啊，这样不就将一样的专业归类了吗

Answer 4

我可以帮你写代码，不难的。你确认一下效果是不是这样？

追问

其实要求是这样的，把相同零件的产品型号归纳到同一个单元格里，后面的数量和层数和第一次出现的零件相同即可，求大神帮忙解答，感激不尽

追答

可以，效果完全一致，看代码，截图

Sub test()
Dim MyDic(1 To 3) As Object, i As Long, c As Variant
For i = 1 To 3
    Set MyDic(i) = CreateObject("scripting.dictionary")
Next i
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    MyDic(1)(Cells(i, 2).Value) = MyDic(1)(Cells(i, 2).Value) & " " & Cells(i, 1).Value
    If Not MyDic(2).exists(Cells(i, 2).Value) Then
        MyDic(2)(Cells(i, 2).Value) = Cells(i, 3).Value
        MyDic(3)(Cells(i, 2).Value) = Cells(i, 4).Value
    End If
Next i
For Each c In MyDic(1).keys
    MyDic(1)(c) = Right(MyDic(1)(c), Len(MyDic(1)(c)) - 1)
Next c
Cells(2, 5).Resize(MyDic(1).Count, 1) = Application.Transpose(MyDic(1).items)
Cells(2, 6).Resize(MyDic(1).Count, 1) = Application.Transpose(MyDic(1).keys)
Cells(2, 7).Resize(MyDic(1).Count, 1) = Application.Transpose(MyDic(2).items)
Cells(2, 8).Resize(MyDic(1).Count, 1) = Application.Transpose(MyDic(3).items)
End Sub

Answer 5

循环+判断语句就OK