[已解决]麻烦给写个代码,谢谢

雄鹰2013

Sub 练习() '雄鹰2017.10.12
Dim arr, brr(1 To 100, 1 To 6), z
Set d = CreateObject("scripting.dictionary")
Sheets("基准价格").Activate
arr = Sheets("采购价").[a1].CurrentRegion
For i = 3 To UBound(arr)
     If Not d.exists(arr(i, 2)) Then
        d(arr(i, 2)) = i
     Else
        d(arr(i, 2) & " ") = i
     End If
Next i
For i = 3 To [a65536].End(3).Row
     If d.exists(Trim(Cells(i, 2))) Then
        n = n + 1
        x = d(Trim(Cells(i, 2)))
        For j = 1 To UBound(arr, 2)
            brr(n, j) = arr(x, j)
        Next j
        d.Remove (Trim(Cells(i, 2)))
     End If
Next i
n = n + 1
For Each k In d.keys
     x = d(k)
     n = n + 1
     For j = 1 To UBound(arr, 2)
         brr(n, j) = arr(x, j)
     Next j
Next k
[g15].Resize(n, UBound(arr, 2)) = brr
End Sub

雄鹰2013

Sub 练习2() '雄鹰2017.10.12
Dim arr, brr(1 To 100, 1 To 6), z
Set d = CreateObject("scripting.dictionary")
Sheets("基准价格").Activate
arr = Sheets("采购价").[a1].CurrentRegion
For i = 3 To UBound(arr)
     If Not d.exists(arr(i, 2)) Then
        d(arr(i, 2)) = i
     Else
        d(arr(i, 2) & " ") = d(arr(i, 2) & " ") & "," & i
     End If
Next i
For i = 3 To [a65536].End(3).Row
     If d.exists(Trim(Cells(i, 2))) Then
        n = n + 1
        x = d(Trim(Cells(i, 2)))
        For j = 1 To UBound(arr, 2)
            brr(n, j) = arr(x, j)
        Next j
        d.Remove (Trim(Cells(i, 2)))
     End If
Next i
n = n + 1
For Each k In d.keys
     If InStr(d(k), ",") Then
        ar = Split(d(k), ",")
        For ii = 1 To UBound(ar)
            x = ar(ii)
            n = n + 1
            For j = 1 To UBound(arr, 2)
                brr(n, j) = arr(x, j)
            Next j
        Next ii
     Else
        x = d(k)
        n = n + 1
        For j = 1 To UBound(arr, 2)
            brr(n, j) = arr(x, j)
        Next j
    End If
Next k
[g15].Resize(n, UBound(arr, 2)) = brr
End Sub

雄鹰2013

Sub 练习3()
Dim arr, brr, crr(1 To 100, 1 To 6)
Sheets("基准价格").Activate
[g3].Resize(1000, 6) = ""
r = [a65536].End(3).Row
rr = 3
Set d = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
arr = Sheets("采购价").[a1].CurrentRegion
For i = 3 To UBound(arr)
     d(arr(i, 2)) = d(arr(i, 2)) & "," & i '名称和行号连接
     dd(i) = "" '放入所有的行号
Next i
brr = Range("a3 :f" & r)
For i = 1 To UBound(brr)
     x = brr(i, 2)
     If d.exists(x) Then
        n = n + 1
        ar = Split(d(x), ",")
        For ii = 1 To UBound(ar)
            y = Val(ar(ii))
            If y <> 0 Then
               For j = 1 To UBound(arr, 2)
                   crr(n, j) = arr(y, j)
               Next j
               ar(ii) = ""
               d(x) = Join(ar, ",") '将原名称对应的行号重新连接(重要)
               Exit For
            End If
        Next ii
     Else '如果采购价中没有该名称那么就将对应的行置空
        n = n + 1
        For j = 1 To UBound(brr, 2)
            crr(n, j) = ""
        Next j
     End If
     If y <> 0 Then dd.Remove (y) '去掉已经使用过的行号
Next i
n = n + 1
For Each k In dd.keys
     n = n + 1
     For j = 1 To UBound(arr, 2)
         crr(n, j) = arr(k, j)
     Next j
Next k
Cells(rr, "g").Resize(n, UBound(arr, 2)) = crr
End Sub