excel里VBA编写代码，急急急！

Question

把相同零件的产品型号归纳到同一个单元格里，后面的数量和层数和第一次出现的零件相同即可，求各位大神帮帮忙，明天就要交差了，

Answer 1

Private Sub CommandButton1_Click()
    Dim sh As Worksheet, rg As Range, rg0 As Range, rg1 As Range
    Dim a, i, d, dC, dD, tmp
    Set d = CreateObject("Scripting.Dictionary")
    Set dC = CreateObject("Scripting.Dictionary")
    Set dD = CreateObject("Scripting.Dictionary")
    Set sh = ActiveSheet
    With sh
    
        Set rg0 = .Range("A:D")  '原数据列位置
        Set rg1 = .Range("E1")   '结果数据，第一个单元格位置
        
        Set rg = Application.Intersect(rg0, .UsedRange)
        If rg Is Nothing Then MsgBox "无数据！", vbCritical: Exit Sub
        If rg.Rows.Count < 2 Or rg.Columns.Count <> 4 Then
            MsgBox "数据设置错误！", vbCritical: Exit Sub
        End If
    End With
    a = rg
    For i = 1 To UBound(a)
        tmp = Trim(a(i, 2))
        If tmp <> "" Then
            If d.Exists(tmp) Then
                d(tmp) = d(tmp) & " " & a(i, 1)
            Else
                d(tmp) = a(i, 1)
                dC(tmp) = a(i, 3)
                dD(tmp) = a(i, 4)
            End If
        End If
    Next
    If d.Count < 2 Then MsgBox "无数据！", vbCritical: Exit Sub
    With rg1.Resize(d.Count, 4)
        .EntireColumn.ClearContents
        .Columns(1) = Application.Transpose(d.items)
        .Columns(2) = Application.Transpose(d.keys)
        .Columns(3) = Application.Transpose(dC.items)
        .Columns(4) = Application.Transpose(dD.items)
    End With
End Sub

追问

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

追答

下面这句前面加个判断就好了：
d(tmp) = d(tmp) & " " & a(i, 1)

改成：
If InStr(1, " " & d(tmp) & " ", " " & a(i, 1) & " ") = 0 Then
d(tmp) = d(tmp) & " " & a(i, 1)
End If

Answer 2

Sub oldyuan()
    Dim Dic As Object, i&, k&, Arr, ArrOut()
    Arr = Range("A2:D" & Cells(Rows.Count, 4).End(3).Row).Value
    ReDim ArrOut(1 To UBound(Arr), 1 To 4)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr)
        If Not Dic.Exists(Arr(i, 2)) Then
            k = k + 1
            Dic(Arr(i, 2)) = k
            ArrOut(k, 1) = Arr(i, 1)
            ArrOut(k, 2) = Arr(i, 2)
            ArrOut(k, 3) = Arr(i, 3)
            ArrOut(k, 4) = Arr(i, 4)
        Else
            ArrOut(Dic(Arr(i, 2)), 1) = ArrOut(Dic(Arr(i, 2)), 1) & " " & Arr(i, 1)
        End If
    Next i
    Columns("E:H").ClearContents
    Range("E1:H1") = Range("A1:D1").Value
    Range("E2").Resize(k, 4) = ArrOut
End Sub

追问

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

追答Sub oldyuan()
    Dim Dic As Object, i&, k&, Arr, ArrOut()
    Arr = Range("A2:D" & Cells(Rows.Count, 4).End(3).Row).Value
    ReDim ArrOut(1 To UBound(Arr), 1 To 4)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr)
        If Not Dic.Exists(Arr(i, 2)) Then
            k = k + 1
            Dic(Arr(i, 2)) = k
            ArrOut(k, 1) = Arr(i, 1)
            ArrOut(k, 2) = Arr(i, 2)
            ArrOut(k, 3) = Arr(i, 3)
            ArrOut(k, 4) = Arr(i, 4)
        Else
            If InStr(ArrOut(Dic(Arr(i, 2)), 1), Arr(i, 1)) = 0 Then
                ArrOut(Dic(Arr(i, 2)), 1) = ArrOut(Dic(Arr(i, 2)), 1) & " " & Arr(i, 1)
            End If
        End If
    Next i
    Columns("E:H").ClearContents
    Range("E1:H1") = Range("A1:D1").Value
    Range("E2").Resize(k, 4) = ArrOut
End Sub

本回答被提问者采纳

Answer 3

能力有限，E的一列我只能写出没有空格的
Sub 汇总()
Dim arr()
n = [a1].End(xlDown).Row
ReDim arr(1 To n - 1, 1 To 4)
arr = Range("a2:d" & n)
For i = 1 To UBound(arr)
For x = i + 1 To UBound(arr)
If arr(i, 2) = arr(x, 2) Then
arr(i, 1) = arr(i, 1) & arr(x, 1)
arr(x, 1) = ""
End If
Next x, i
k = 2
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then
Cells(k, 5) = arr(i, 1)
Cells(k, 6) = arr(i, 2)
Cells(k, 7) = arr(i, 3)
Cells(k, 8) = arr(i, 4)
k = k + 1
End If
Next
End Sub追问

还可以啦，至少能写的这么多，我真是一点都不会

本回答被网友采纳

Answer 4

可以写的，请追问一下。追问

好吧。。。。。。。。。

追答

附件看私信。
Sub Macro1()
Dim row_last As Integer
Dim a As Integer, b As String, c As String, i As Integer
Dim flag As Boolean, temp1 As Boolean, temp2 As Boolean
' ÕÒ³ö×îºóÒ»ÐÐ
Selection.SpecialCells(xlCellTypeLastCell).Select
flag = False
Do While flag = False
If ActiveCell.Row = 1 Then
Exit Do
End If
Selection.End(xlToLeft).Select
temp1 = IsEmpty(ActiveCell.Value)
Selection.End(xlToRight).Select
temp2 = IsEmpty(ActiveCell.Value)
If temp1 = True And temp2 = True Then
Selection.Offset(-1, 0).Select
Else
flag = True
Exit Do
End If
Loop
Selection.End(xlToLeft).Select
row_last = ActiveCell.Row
' ת»»
a = 2
b = Cells(2, 2)
c = Cells(2, 1)
Cells(a, 6) = Cells(2, 2)
Cells(a, 7) = Cells(2, 3)
Cells(a, 8) = Cells(2, 4)
Cells(a, 5) = Cells(2, 1)
For i = 3 To row_last
If b = Cells(i, 2) Then
c = c & " " & Cells(i, 1)
Cells(a, 5) = c
Else

Answer 5

数量是什么规律 看不明白追问

数量是当排列的第一个零件遇到的数量是几，那这个零件的数量就是几，比如列表的第一个零件甲数量是2，就让所有产品型号的零件甲都是2，层数也一样的道理。我说得清楚吗？

追答

用函数做 需要两步 用VBA做 直接能做

追问

帮我写个代码呗，感激不尽

追答

=INDEX($A:$A,SMALL(IF($B$2:$B$17=$F2,ROW($1:$16),4^4),COLUMN(A1))+1)&""
这个是取型号的 右拉就行 拉完再合到一起
数量和层数用 VLOOKUP引用就行