پرسش اداغام چند سلول متنی بر اساس یک شرط در یک سلول دیگر

[nima6223]

دوستان گلم سلام .
یک مشکلی برام پیش اومده خیلی کارم گیر است عزیران محبت نمایید راهنمایی بفرمایید.

یک فایل دیتایی دارم که حدودا 2000 رکورد داره و من میخوام :
1-جمع هر کالا در یک شیت دیگر قرار گیرد
2-در یک سلول مقابل جمع در هر ردیف شماره پروژه های درخواست کنندگان اون کالا درج بشود
نمونه فایل را پیوست کردم شامل دو شیت دیتا و خروجی

[mrhartsclube]

سلام دوست عزیز

تابع مد نظر شما:

Sub Collect()

Dim i As Long, j As Integer, k As Integer

Dim Found As Boolean

k = 1

j = 1

i = 2

Dim Objects() As String, Counts() As Long, ProjNum() As String

ReDim Objects(1)

ReDim Counts(1)

ReDim ProjNum(1)

Objects(k) = (Worksheets("data").Cells(i, "C"))

Counts(k) = (Worksheets("data").Cells(i, "D"))

ProjNum(k) = (Worksheets("data").Cells(i, "B"))

i = 3

While (Worksheets("data").Cells(i, "C") <> "")

      Found = False

    For j = 1 To UBound(Objects)

        If Objects(j) = Worksheets("data").Cells(i, "C") Then

              Counts(j) = Val(Counts(j)) + Val((Worksheets("data").Cells(i, "D")))

              ProjNum(j) = ProjNum(j) & " " & (Worksheets("data").Cells(i, "B"))

              Found = True

              Exit For

        End If

    Next j

    If Not Found Then

          k = k + 1

        ReDim Preserve Objects(k)

        ReDim Preserve Counts(k)

        ReDim Preserve ProjNum(k)

        Objects(k) = (Worksheets("data").Cells(i, "C"))

        Counts(k) = (Worksheets("data").Cells(i, "D"))

        ProjNum(k) = (Worksheets("data").Cells(i, "B"))

    End If

    i = i + 1

Wend

For i = 1 To UBound(Objects)

    Worksheets("out").Cells(i + 1, "A").Value = Objects(i)

    Worksheets("out").Cells(i + 1, "B").Value = Counts(i)

    Worksheets("out").Cells(i + 1, "C").Value = ProjNum(i)

Next i

End Sub